diff --git a/ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs b/ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs index 710994dcee..2253d623ec 100644 --- a/ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs +++ b/ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs @@ -43,12 +43,7 @@ parseDBAnalyserConfig = <*> parseAnalysis <*> parseLimit <*> Foldable.asum - [ flag' V1InMem $ - mconcat - [ long "v1-in-mem" - , help "use v1 in-memory backing store [deprecated]" - ] - , flag' V1LMDB $ + [ flag' V1LMDB $ mconcat [ long "lmdb" , help "use v1 LMDB backing store" diff --git a/ouroboros-consensus-cardano/app/Ouroboros/Consensus/Cardano/StreamingLedgerTables.hs b/ouroboros-consensus-cardano/app/Ouroboros/Consensus/Cardano/StreamingLedgerTables.hs new file mode 100644 index 0000000000..693ae277b7 --- /dev/null +++ b/ouroboros-consensus-cardano/app/Ouroboros/Consensus/Cardano/StreamingLedgerTables.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Ouroboros.Consensus.Cardano.StreamingLedgerTables + ( mkInMemYieldArgs + , mkInMemSinkArgs + ) where + +import Cardano.Ledger.Binary +import Cardano.Ledger.Core (ByronEra, Era, eraDecoder, toEraCBOR) +import qualified Cardano.Ledger.Shelley.API as SL +import qualified Cardano.Ledger.Shelley.LedgerState as SL +import qualified Cardano.Ledger.State as SL +import qualified Codec.CBOR.Encoding +import Control.ResourceRegistry +import Data.Proxy +import Data.SOP.BasicFunctors +import Data.SOP.Functors +import Data.SOP.Strict +import qualified Data.SOP.Telescope as Telescope +import Lens.Micro +import Ouroboros.Consensus.Byron.Ledger +import Ouroboros.Consensus.Cardano.Block +import Ouroboros.Consensus.Cardano.Ledger +import Ouroboros.Consensus.HardFork.Combinator +import Ouroboros.Consensus.HardFork.Combinator.State +import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Shelley.Ledger +import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () +import Ouroboros.Consensus.Storage.LedgerDB.API +import Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as V2 +import System.Directory +import System.FS.API +import System.FS.IO + +type L = LedgerState (CardanoBlock StandardCrypto) + +mkInMemYieldArgs :: FilePath -> L EmptyMK -> ResourceRegistry IO -> IO (YieldArgs IO V2.Mem L) +mkInMemYieldArgs fp (HardForkLedgerState (HardForkState idx)) _ = + let + np :: + NP + (Current (Flip LedgerState EmptyMK) -.-> K (Decoders L)) + (CardanoEras StandardCrypto) + np = + (Fn $ const $ K $ error "Byron") + :* (Fn $ K . fromEra ShelleyTxOut . unFlip . currentState) + :* (Fn $ K . fromEra AllegraTxOut . unFlip . currentState) + :* (Fn $ K . fromEra MaryTxOut . unFlip . currentState) + :* (Fn $ K . fromEra AlonzoTxOut . unFlip . currentState) + :* (Fn $ K . fromEra BabbageTxOut . unFlip . currentState) + :* (Fn $ K . fromEra ConwayTxOut . unFlip . currentState) + :* (Fn $ K . fromEra DijkstraTxOut . unFlip . currentState) + :* Nil + in + pure $ + YieldInMemory + (SomeHasFS . ioHasFS) + fp + (hcollapse $ hap np $ Telescope.tip idx) + where + fromEra :: + forall proto era. + ShelleyCompatible proto era => + (TxOut (LedgerState (ShelleyBlock proto era)) -> CardanoTxOut StandardCrypto) -> + LedgerState (ShelleyBlock proto era) EmptyMK -> + Decoders L + fromEra toCardanoTxOut st = + let certInterns = + internsFromMap $ + shelleyLedgerState st + ^. SL.nesEsL + . SL.esLStateL + . SL.lsCertStateL + . SL.certDStateL + . SL.accountsL + . SL.accountsMapL + in Decoders + (eraDecoder @era decodeMemPack) + (eraDecoder @era $ toCardanoTxOut <$> decShareCBOR certInterns) + +mkInMemSinkArgs :: + FilePath -> + L EmptyMK -> + ResourceRegistry IO -> + IO (SinkArgs IO V2.Mem L) +mkInMemSinkArgs fp (HardForkLedgerState (HardForkState idx)) _ = do + currDir <- getCurrentDirectory + let + np = + (Fn $ const $ K $ encOne (Proxy @ByronEra)) + :* (Fn $ const $ K $ encOne (Proxy @ShelleyEra)) + :* (Fn $ const $ K $ encOne (Proxy @AllegraEra)) + :* (Fn $ const $ K $ encOne (Proxy @MaryEra)) + :* (Fn $ const $ K $ encOne (Proxy @AlonzoEra)) + :* (Fn $ const $ K $ encOne (Proxy @BabbageEra)) + :* (Fn $ const $ K $ encOne (Proxy @ConwayEra)) + :* (Fn $ const $ K $ encOne (Proxy @DijkstraEra)) + :* Nil + pure $ + uncurry + (SinkInMemory 1000) + (hcollapse $ hap np $ Telescope.tip idx) + (SomeHasFS $ ioHasFS $ MountPoint currDir) + fp + where + encOne :: + forall era. + Era era => + Proxy era -> + (TxIn L -> Codec.CBOR.Encoding.Encoding, TxOut L -> Codec.CBOR.Encoding.Encoding) + encOne _ = + (toEraCBOR @era . encodeMemPack, toEraCBOR @era . eliminateCardanoTxOut (const encodeMemPack)) diff --git a/ouroboros-consensus-cardano/app/snapshot-converter.hs b/ouroboros-consensus-cardano/app/snapshot-converter.hs index 3fbf99cc96..6802074a06 100644 --- a/ouroboros-consensus-cardano/app/snapshot-converter.hs +++ b/ouroboros-consensus-cardano/app/snapshot-converter.hs @@ -1,8 +1,10 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} @@ -30,11 +32,12 @@ import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.Basics import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Node.ProtocolInfo +import Ouroboros.Consensus.Storage.LedgerDB.API import Ouroboros.Consensus.Storage.LedgerDB.Snapshots import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as V1 +import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM import Ouroboros.Consensus.Util.CRC -import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.StreamingLedgerTables +import Ouroboros.Consensus.Util.IOLike hiding (yield) import System.Console.ANSI import qualified System.Directory as D import System.Exit @@ -45,6 +48,7 @@ import System.FilePath (splitDirectories) import qualified System.FilePath as F import System.IO import System.ProgressBar +import System.Random data Format = Mem FilePath @@ -215,24 +219,29 @@ instance StandardHash blk => Show (Error blk) where ["Error when reading entries in the UTxO tables: ", show df] show Cancelled = "Cancelled" -data InEnv = InEnv +data InEnv backend = InEnv { inState :: LedgerState (CardanoBlock StandardCrypto) EmptyMK , inFilePath :: FilePath , inStream :: LedgerState (CardanoBlock StandardCrypto) EmptyMK -> ResourceRegistry IO -> - IO (YieldArgs (LedgerState (CardanoBlock StandardCrypto)) IO) + IO (SomeBackend YieldArgs) , inProgressMsg :: String , inCRC :: CRC , inSnapReadCRC :: Maybe CRC } -data OutEnv = OutEnv +data SomeBackend c where + SomeBackend :: + StreamingBackend IO backend (LedgerState (CardanoBlock StandardCrypto)) => + c IO backend (LedgerState (CardanoBlock StandardCrypto)) -> SomeBackend c + +data OutEnv backend = OutEnv { outFilePath :: FilePath , outStream :: LedgerState (CardanoBlock StandardCrypto) EmptyMK -> ResourceRegistry IO -> - IO (SinkArgs (LedgerState (CardanoBlock StandardCrypto)) IO) + IO (SomeBackend SinkArgs) , outCreateExtra :: Maybe FilePath , outDeleteExtra :: Maybe FilePath , outProgressMsg :: String @@ -356,7 +365,7 @@ main = withStdTerminalHandles $ do InEnv st fp - (fromInMemory (fp F. "tables")) + (\a b -> SomeBackend <$> mkInMemYieldArgs (fp F. "tables") a b) ("InMemory@[" <> fp <> "]") c mtd @@ -375,7 +384,7 @@ main = withStdTerminalHandles $ do InEnv st fp - (fromLMDB (fp F. "tables") defaultLMDBLimits) + (\a b -> SomeBackend <$> V1.mkLMDBYieldArgs (fp F. "tables") defaultLMDBLimits a b) ("LMDB@[" <> fp <> "]") c mtd @@ -394,7 +403,9 @@ main = withStdTerminalHandles $ do InEnv st fp - (fromLSM lsmDbPath (last $ splitDirectories fp)) + ( \a b -> + SomeBackend <$> mkLSMYieldArgs lsmDbPath (last $ splitDirectories fp) stdMkBlockIOFS newStdGen a b + ) ("LSM@[" <> lsmDbPath <> "]") c mtd @@ -412,7 +423,7 @@ main = withStdTerminalHandles $ do pure $ OutEnv fp - (toInMemory (fp F. "tables")) + (\a b -> SomeBackend <$> mkInMemSinkArgs (fp F. "tables") a b) (Just "tables") (Nothing) ("InMemory@[" <> fp <> "]") @@ -429,7 +440,7 @@ main = withStdTerminalHandles $ do pure $ OutEnv fp - (toLMDB fp defaultLMDBLimits) + (\a b -> SomeBackend <$> V1.mkLMDBSinkArgs fp defaultLMDBLimits a b) Nothing Nothing ("LMDB@[" <> fp <> "]") @@ -446,12 +457,32 @@ main = withStdTerminalHandles $ do pure $ OutEnv fp - (toLSM lsmDbPath (last $ splitDirectories fp)) + ( \a b -> + SomeBackend <$> mkLSMSinkArgs lsmDbPath (last $ splitDirectories fp) stdMkBlockIOFS newStdGen a b + ) Nothing (Just lsmDbPath) ("LSM@[" <> lsmDbPath <> "]") UTxOHDLSMSnapshot +stream :: + LedgerState (CardanoBlock StandardCrypto) EmptyMK -> + ( LedgerState (CardanoBlock StandardCrypto) EmptyMK -> + ResourceRegistry IO -> + IO (SomeBackend YieldArgs) + ) -> + ( LedgerState (CardanoBlock StandardCrypto) EmptyMK -> + ResourceRegistry IO -> + IO (SomeBackend SinkArgs) + ) -> + ExceptT DeserialiseFailure IO (Maybe CRC, Maybe CRC) +stream st mYieldArgs mSinkArgs = + ExceptT $ + withRegistry $ \reg -> do + (SomeBackend (yArgs :: YieldArgs IO backend1 l)) <- mYieldArgs st reg + (SomeBackend (sArgs :: SinkArgs IO backend2 l)) <- mSinkArgs st reg + runExceptT $ yield (Proxy @backend1) yArgs st $ sink (Proxy @backend2) sArgs st + -- Helpers -- UI diff --git a/ouroboros-consensus-cardano/changelog.d/20251010_121135_javier.sagredo_extract_2.md b/ouroboros-consensus-cardano/changelog.d/20251010_121135_javier.sagredo_extract_2.md new file mode 100644 index 0000000000..1a6055e7fd --- /dev/null +++ b/ouroboros-consensus-cardano/changelog.d/20251010_121135_javier.sagredo_extract_2.md @@ -0,0 +1,3 @@ + diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index e8368a7e5d..78fd3c6786 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -101,7 +101,6 @@ library Ouroboros.Consensus.Cardano.Ledger Ouroboros.Consensus.Cardano.Node Ouroboros.Consensus.Cardano.QueryHF - Ouroboros.Consensus.Cardano.StreamingLedgerTables Ouroboros.Consensus.Shelley.Crypto Ouroboros.Consensus.Shelley.Eras Ouroboros.Consensus.Shelley.HFEras @@ -160,10 +159,7 @@ library contra-tracer, crypton, deepseq, - directory, - filepath, formatting >=6.3 && <7.3, - fs-api, measures, mempack, microlens, @@ -172,15 +168,12 @@ library ouroboros-consensus ^>=0.28, ouroboros-consensus-protocol ^>=0.13, ouroboros-network-api ^>=0.16, - random, - resource-registry, serialise ^>=0.2, singletons ^>=3.0, small-steps, sop-core ^>=0.5, sop-extras ^>=0.4, strict-sop-core ^>=0.1, - temporary, text, these ^>=1.2, validation, @@ -593,7 +586,7 @@ library unstable-cardano-tools network, network-mux, nothunks, - ouroboros-consensus ^>=0.28, + ouroboros-consensus:{ouroboros-consensus, ouroboros-consensus-lmdb, ouroboros-consensus-lsm} ^>=0.28, ouroboros-consensus-cardano, ouroboros-consensus-diffusion ^>=0.24, ouroboros-consensus-protocol:{ouroboros-consensus-protocol, unstable-protocol-testlib} ^>=0.13, @@ -701,21 +694,33 @@ executable immdb-server executable snapshot-converter import: common-exe hs-source-dirs: app + other-modules: + Ouroboros.Consensus.Cardano.StreamingLedgerTables + main-is: snapshot-converter.hs build-depends: ansi-terminal, base, cardano-crypto-class, + cardano-ledger-binary, + cardano-ledger-core, + cardano-ledger-shelley, + cborg, directory, filepath, fs-api, + microlens, mtl, optparse-applicative, - ouroboros-consensus, + ouroboros-consensus:{ouroboros-consensus, ouroboros-consensus-lmdb, ouroboros-consensus-lsm}, ouroboros-consensus-cardano, ouroboros-consensus-cardano:unstable-cardano-tools, + random, resource-registry, serialise, + sop-core, + sop-extras, + strict-sop-core, terminal-progress-bar, text, with-utf8, diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/StreamingLedgerTables.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/StreamingLedgerTables.hs deleted file mode 100644 index e064bf4e04..0000000000 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/StreamingLedgerTables.hs +++ /dev/null @@ -1,219 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - -module Ouroboros.Consensus.Cardano.StreamingLedgerTables - ( fromInMemory - , fromLSM - , fromLMDB - , toLMDB - , toLSM - , toInMemory - ) where - -import Cardano.Ledger.BaseTypes (WithOrigin (..)) -import Cardano.Ledger.Binary -import Cardano.Ledger.Core (ByronEra, Era, eraDecoder, toEraCBOR) -import qualified Cardano.Ledger.Shelley.API as SL -import qualified Cardano.Ledger.Shelley.LedgerState as SL -import qualified Cardano.Ledger.State as SL -import qualified Codec.CBOR.Encoding -import Control.ResourceRegistry -import Control.Tracer (nullTracer) -import Data.Proxy -import Data.SOP.BasicFunctors -import Data.SOP.Functors -import Data.SOP.Strict -import qualified Data.SOP.Telescope as Telescope -import qualified Data.Text as T -import Lens.Micro -import Ouroboros.Consensus.Byron.Ledger -import Ouroboros.Consensus.Cardano.Block -import Ouroboros.Consensus.Cardano.Ledger -import Ouroboros.Consensus.HardFork.Combinator -import Ouroboros.Consensus.HardFork.Combinator.State -import Ouroboros.Consensus.Ledger.Abstract -import Ouroboros.Consensus.Ledger.Tables.Utils (emptyLedgerTables) -import Ouroboros.Consensus.Shelley.Ledger -import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () -import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API -import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB -import Ouroboros.Consensus.Storage.LedgerDB.V2.Args -import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM -import Ouroboros.Consensus.Util.StreamingLedgerTables -import System.Directory -import System.FS.API -import System.FS.IO -import System.FilePath as FilePath -import System.IO.Temp -import System.Random - -type L = LedgerState (CardanoBlock StandardCrypto) - -fromInMemory :: FilePath -> L EmptyMK -> ResourceRegistry IO -> IO (YieldArgs L IO) -fromInMemory fp (HardForkLedgerState (HardForkState idx)) _ = - let - np :: - NP - (Current (Flip LedgerState EmptyMK) -.-> K (Decoders L)) - (CardanoEras StandardCrypto) - np = - (Fn $ const $ K $ error "Byron") - :* (Fn $ K . fromEra ShelleyTxOut . unFlip . currentState) - :* (Fn $ K . fromEra AllegraTxOut . unFlip . currentState) - :* (Fn $ K . fromEra MaryTxOut . unFlip . currentState) - :* (Fn $ K . fromEra AlonzoTxOut . unFlip . currentState) - :* (Fn $ K . fromEra BabbageTxOut . unFlip . currentState) - :* (Fn $ K . fromEra ConwayTxOut . unFlip . currentState) - :* (Fn $ K . fromEra DijkstraTxOut . unFlip . currentState) - :* Nil - in - pure $ - YieldInMemory - (SomeHasFS . ioHasFS) - fp - (hcollapse $ hap np $ Telescope.tip idx) - where - fromEra :: - forall proto era. - ShelleyCompatible proto era => - (TxOut (LedgerState (ShelleyBlock proto era)) -> CardanoTxOut StandardCrypto) -> - LedgerState (ShelleyBlock proto era) EmptyMK -> - Decoders L - fromEra toCardanoTxOut st = - let certInterns = - internsFromMap $ - shelleyLedgerState st - ^. SL.nesEsL - . SL.esLStateL - . SL.lsCertStateL - . SL.certDStateL - . SL.accountsL - . SL.accountsMapL - in Decoders - (eraDecoder @era decodeMemPack) - (eraDecoder @era $ toCardanoTxOut <$> decShareCBOR certInterns) - -fromLMDB :: FilePath -> LMDB.LMDBLimits -> L EmptyMK -> ResourceRegistry IO -> IO (YieldArgs L IO) -fromLMDB fp limits hint reg = do - let (dbPath, snapName) = splitFileName fp - tempDir <- getCanonicalTemporaryDirectory - let lmdbTemp = tempDir FilePath. "lmdb_streaming_in" - removePathForcibly lmdbTemp - _ <- - allocate - reg - (\_ -> System.Directory.createDirectory lmdbTemp) - (\_ -> removePathForcibly lmdbTemp) - (_, bs) <- - allocate - reg - ( \_ -> do - LMDB.newLMDBBackingStore - nullTracer - limits - (LiveLMDBFS $ SomeHasFS $ ioHasFS $ MountPoint lmdbTemp) - (SnapshotsFS $ SomeHasFS $ ioHasFS $ MountPoint dbPath) - (InitFromCopy hint (mkFsPath [snapName])) - ) - bsClose - (_, bsvh) <- allocate reg (\_ -> bsValueHandle bs) bsvhClose - pure (YieldLMDB 1000 bsvh) - -fromLSM :: - FilePath -> - String -> - L EmptyMK -> - ResourceRegistry IO -> - IO (YieldArgs L IO) -fromLSM fp snapName _ reg = do - (_, SomeHasFSAndBlockIO hasFS blockIO) <- stdMkBlockIOFS fp reg - salt <- fst . genWord64 <$> newStdGen - (_, session) <- - allocate reg (\_ -> openSession nullTracer hasFS blockIO salt (mkFsPath [])) closeSession - tb <- - allocate - reg - ( \_ -> - openTableFromSnapshot - session - (toSnapshotName snapName) - (SnapshotLabel $ T.pack "UTxO table") - ) - closeTable - YieldLSM 1000 <$> newLSMLedgerTablesHandle nullTracer reg tb - -toLMDB :: - FilePath -> - LMDB.LMDBLimits -> - L EmptyMK -> - ResourceRegistry IO -> - IO (SinkArgs L IO) -toLMDB fp limits hint reg = do - let (snapDir, snapName) = splitFileName fp - tempDir <- getCanonicalTemporaryDirectory - let lmdbTemp = tempDir FilePath. "lmdb_streaming_out" - removePathForcibly lmdbTemp - _ <- - allocate reg (\_ -> System.Directory.createDirectory lmdbTemp) (\_ -> removePathForcibly lmdbTemp) - (_, bs) <- - allocate - reg - ( \_ -> - LMDB.newLMDBBackingStore - nullTracer - limits - (LiveLMDBFS $ SomeHasFS $ ioHasFS $ MountPoint lmdbTemp) - (SnapshotsFS $ SomeHasFS $ ioHasFS $ MountPoint snapDir) - (InitFromValues (At 0) hint emptyLedgerTables) - ) - bsClose - pure $ SinkLMDB 1000 (bsWrite bs) (\h -> bsCopy bs h (mkFsPath [snapName, "tables"])) - -toInMemory :: - FilePath -> - L EmptyMK -> - ResourceRegistry IO -> - IO (SinkArgs L IO) -toInMemory fp (HardForkLedgerState (HardForkState idx)) _ = do - currDir <- getCurrentDirectory - let - np = - (Fn $ const $ K $ encOne (Proxy @ByronEra)) - :* (Fn $ const $ K $ encOne (Proxy @ShelleyEra)) - :* (Fn $ const $ K $ encOne (Proxy @AllegraEra)) - :* (Fn $ const $ K $ encOne (Proxy @MaryEra)) - :* (Fn $ const $ K $ encOne (Proxy @AlonzoEra)) - :* (Fn $ const $ K $ encOne (Proxy @BabbageEra)) - :* (Fn $ const $ K $ encOne (Proxy @ConwayEra)) - :* (Fn $ const $ K $ encOne (Proxy @DijkstraEra)) - :* Nil - pure $ - uncurry - (SinkInMemory 1000) - (hcollapse $ hap np $ Telescope.tip idx) - (SomeHasFS $ ioHasFS $ MountPoint currDir) - fp - where - encOne :: - forall era. - Era era => - Proxy era -> - (TxIn L -> Codec.CBOR.Encoding.Encoding, TxOut L -> Codec.CBOR.Encoding.Encoding) - encOne _ = - (toEraCBOR @era . encodeMemPack, toEraCBOR @era . eliminateCardanoTxOut (const encodeMemPack)) - -toLSM :: - FilePath -> - String -> - L EmptyMK -> - ResourceRegistry IO -> - IO (SinkArgs L IO) -toLSM fp snapName _ reg = do - removePathForcibly fp - System.Directory.createDirectory fp - (_, SomeHasFSAndBlockIO hasFS blockIO) <- stdMkBlockIOFS fp reg - salt <- fst . genWord64 <$> newStdGen - (_, session) <- - allocate reg (\_ -> newSession nullTracer hasFS blockIO salt (mkFsPath [])) closeSession - pure (SinkLSM 1000 snapName session) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs index c2e4587c9b..5a2fe7776b 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs @@ -23,6 +23,7 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Abstract import Ouroboros.Consensus.Ledger.Basics +import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Inspect import qualified Ouroboros.Consensus.Ledger.SupportsMempool as LedgerSupportsMempool ( HasTxs @@ -39,11 +40,11 @@ import Ouroboros.Consensus.Storage.LedgerDB (TraceEvent (..)) import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB import qualified Ouroboros.Consensus.Storage.LedgerDB.V1 as LedgerDB.V1 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as LedgerDB.V1 +import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore as LedgerDB.V1 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB -import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots as V1 +import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots as LedgerDB.V1 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2 as LedgerDB.V2 -import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as LedgerDB.V2 -import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Backend as LedgerDB.V2 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM import Ouroboros.Consensus.Util.Args @@ -60,6 +61,7 @@ import Text.Printf (printf) -------------------------------------------------------------------------------} openLedgerDB :: + forall blk. ( LedgerSupportsProtocol blk , InspectLedger blk , HasHardForkHistory blk @@ -70,59 +72,42 @@ openLedgerDB :: ( LedgerDB.LedgerDB' IO blk , LedgerDB.TestInternals' IO blk ) -openLedgerDB lgrDbArgs@LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs = LedgerDB.LedgerDbFlavorArgsV1 bss} = do - let snapManager = V1.snapshotManager lgrDbArgs - (ledgerDB, _, intLedgerDB) <- - LedgerDB.openDBInternal - lgrDbArgs - ( LedgerDB.V1.mkInitDb - lgrDbArgs - bss - (\_ -> error "no replay") - snapManager - (LedgerDB.praosGetVolatileSuffix $ LedgerDB.ledgerDbCfgSecParam $ LedgerDB.lgrConfig lgrDbArgs) - ) - snapManager - emptyStream - genesisPoint - pure (ledgerDB, intLedgerDB) -openLedgerDB lgrDbArgs@LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs = LedgerDB.LedgerDbFlavorArgsV2 args} = do - (snapManager, bss') <- case args of - V2.V2Args V2.InMemoryHandleArgs -> pure (InMemory.snapshotManager lgrDbArgs, V2.InMemoryHandleEnv) - V2.V2Args (V2.LSMHandleArgs (V2.LSMArgs path salt mkFS)) -> do - (rk1, V2.SomeHasFSAndBlockIO fs' blockio) <- mkFS (LedgerDB.lgrRegistry lgrDbArgs) - session <- - allocate - (LedgerDB.lgrRegistry lgrDbArgs) - ( \_ -> - LSM.openSession - ( LedgerDBFlavorImplEvent . LedgerDB.FlavorImplSpecificTraceV2 . V2.LSMTrace - >$< LedgerDB.lgrTracer lgrDbArgs - ) - fs' - blockio - salt - path - ) - LSM.closeSession - pure - ( LSM.snapshotManager (snd session) lgrDbArgs - , V2.LSMHandleEnv (V2.LSMResources (fst session) (snd session) rk1) - ) - (ledgerDB, _, intLedgerDB) <- - LedgerDB.openDBInternal - lgrDbArgs - ( LedgerDB.V2.mkInitDb - lgrDbArgs - bss' - (\_ -> error "no replay") - snapManager - (LedgerDB.praosGetVolatileSuffix $ LedgerDB.ledgerDbCfgSecParam $ LedgerDB.lgrConfig lgrDbArgs) - ) - snapManager - emptyStream - genesisPoint - pure (ledgerDB, intLedgerDB) +openLedgerDB args = do + (ldb, _, od) <- case LedgerDB.lgrBackendArgs args of + LedgerDB.LedgerDbBackendArgsV1 bss -> + let snapManager = LedgerDB.V1.snapshotManager args + initDb = + LedgerDB.V1.mkInitDb + args + bss + (\_ -> pure (error "no stream")) + snapManager + (LedgerDB.praosGetVolatileSuffix $ LedgerDB.ledgerDbCfgSecParam $ LedgerDB.lgrConfig args) + in LedgerDB.openDBInternal args initDb snapManager emptyStream genesisPoint + LedgerDB.LedgerDbBackendArgsV2 (LedgerDB.V2.SomeBackendArgs bArgs) -> do + res <- + LedgerDB.V2.mkResources + (Proxy @blk) + (LedgerDBFlavorImplEvent . LedgerDB.FlavorImplSpecificTraceV2 >$< LedgerDB.lgrTracer args) + bArgs + (LedgerDB.lgrRegistry args) + (LedgerDB.lgrHasFS args) + let snapManager = + LedgerDB.V2.snapshotManager + (Proxy @blk) + res + (configCodec . getExtLedgerCfg . LedgerDB.ledgerDbCfg $ LedgerDB.lgrConfig args) + (LedgerDBSnapshotEvent >$< LedgerDB.lgrTracer args) + (LedgerDB.lgrHasFS args) + let initDb = + LedgerDB.V2.mkInitDb + args + (\_ -> pure (error "no stream")) + snapManager + (LedgerDB.praosGetVolatileSuffix $ LedgerDB.ledgerDbCfgSecParam $ LedgerDB.lgrConfig args) + res + LedgerDB.openDBInternal args initDb snapManager emptyStream genesisPoint + pure (ldb, od) emptyStream :: Applicative m => ImmutableDB.StreamAPI m blk a emptyStream = ImmutableDB.StreamAPI $ \_ k -> k $ Right $ pure ImmutableDB.NoMoreItems @@ -158,32 +143,23 @@ analyse dbaConfig args = let shfs = Node.stdMkChainDbHasFS dbDir chunkInfo = Node.nodeImmutableDbChunkInfo (configStorage cfg) flavargs = case ldbBackend of - V1InMem -> - LedgerDB.LedgerDbFlavorArgsV1 - ( LedgerDB.V1.V1Args - LedgerDB.V1.DisableFlushing - LedgerDB.V1.InMemoryBackingStoreArgs - ) V1LMDB -> - LedgerDB.LedgerDbFlavorArgsV1 - ( LedgerDB.V1.V1Args - LedgerDB.V1.DisableFlushing - ( LedgerDB.V1.LMDBBackingStoreArgs - "lmdb" - defaultLMDBLimits - Dict.Dict - ) - ) + LedgerDB.LedgerDbBackendArgsV1 + $ LedgerDB.V1.V1Args + LedgerDB.V1.DisableFlushing + $ LedgerDB.V1.SomeBackendArgs + $ LMDB.LMDBBackingStoreArgs + "lmdb" + defaultLMDBLimits + Dict.Dict V2InMem -> - LedgerDB.LedgerDbFlavorArgsV2 - (LedgerDB.V2.V2Args LedgerDB.V2.InMemoryHandleArgs) + LedgerDB.LedgerDbBackendArgsV2 $ + LedgerDB.V2.SomeBackendArgs InMemory.InMemArgs V2LSM -> - LedgerDB.LedgerDbFlavorArgsV2 - ( LedgerDB.V2.V2Args - ( LedgerDB.V2.LSMHandleArgs - (LedgerDB.V2.LSMArgs (mkFsPath ["lsm"]) lsmSalt (LSM.stdMkBlockIOFS dbDir)) - ) - ) + LedgerDB.LedgerDbBackendArgsV2 $ + LedgerDB.V2.SomeBackendArgs $ + LSM.LSMArgs (mkFsPath ["lsm"]) lsmSalt (LSM.stdMkBlockIOFS dbDir) + args' = ChainDB.completeChainDbArgs registry diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Types.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Types.hs index d7bdc8fb63..aaa120215b 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Types.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Types.hs @@ -49,7 +49,7 @@ newtype NumberOfBlocks = NumberOfBlocks {unNumberOfBlocks :: Word64} data Limit = Limit Int | Unlimited -data LedgerDBBackend = V1InMem | V1LMDB | V2InMem | V2LSM +data LedgerDBBackend = V1LMDB | V2InMem | V2LSM -- | The extent of the ChainDB on-disk files validation. This is completely -- unrelated to validation of the ledger rules. diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs index f3c184472e..885af6c734 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs @@ -52,7 +52,8 @@ import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB (getTipPoint) import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB -import Ouroboros.Consensus.Storage.LedgerDB.V1.Args as LedgerDB.V1 +import Ouroboros.Consensus.Storage.LedgerDB.V2.Backend +import Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory import Ouroboros.Consensus.Util.IOLike (atomically) import Ouroboros.Network.Block import Ouroboros.Network.Point (WithOrigin (..)) @@ -147,8 +148,7 @@ synthesize genTxs DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir let epochSize = sgEpochLength confShelleyGenesis chunkInfo = Node.nodeImmutableDbChunkInfo (configStorage pInfoConfig) - bss = LedgerDB.V1.V1Args LedgerDB.V1.DisableFlushing InMemoryBackingStoreArgs - flavargs = LedgerDB.LedgerDbFlavorArgsV1 bss + flavargs = LedgerDB.LedgerDbBackendArgsV2 $ SomeBackendArgs InMemArgs dbArgs = ChainDB.completeChainDbArgs registry diff --git a/ouroboros-consensus-diffusion/changelog.d/20251010_121130_javier.sagredo_extract_2.md b/ouroboros-consensus-diffusion/changelog.d/20251010_121130_javier.sagredo_extract_2.md new file mode 100644 index 0000000000..04192cc013 --- /dev/null +++ b/ouroboros-consensus-diffusion/changelog.d/20251010_121130_javier.sagredo_extract_2.md @@ -0,0 +1,23 @@ + + + + + +### Breaking + +- Expect `srnLedgerDbBackendArgs :: LedgerDbBackendArgs m blk` as an argument, type which changed semantics in the abstract layer. diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs index d92b7f8e07..efd7018046 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs @@ -53,7 +53,6 @@ module Ouroboros.Consensus.Node , pattern DoDiskSnapshotChecksum , pattern NoDoDiskSnapshotChecksum , ChainSyncIdleTimeout (..) - , LedgerDbBackendArgs (..) -- * Internal helpers , mkNodeKernelArgs @@ -127,8 +126,6 @@ import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB import Ouroboros.Consensus.Storage.LedgerDB.Args import Ouroboros.Consensus.Storage.LedgerDB.Snapshots -import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 -import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () @@ -176,11 +173,11 @@ import Ouroboros.Network.Protocol.ChainSync.Codec (timeLimitsChainSync) import Ouroboros.Network.RethrowPolicy import qualified SafeWildCards import System.Exit (ExitCode (..)) -import System.FS.API (SomeHasFS (..), mkFsPath) +import System.FS.API (SomeHasFS (..)) import System.FS.API.Types (MountPoint (..)) import System.FS.IO (ioHasFS) -import System.FilePath (splitDirectories, ()) -import System.Random (StdGen, genWord64, newStdGen, randomIO, split) +import System.FilePath (()) +import System.Random (StdGen, newStdGen, randomIO, split) {------------------------------------------------------------------------------- The arguments to the Consensus Layer node functionality @@ -320,7 +317,7 @@ data LowLevelRunNodeArgs m addrNTN addrNTC blk , llrnMaxClockSkew :: InFutureCheck.ClockSkew -- ^ Maximum clock skew , llrnPublicPeerSelectionStateVar :: StrictSTM.StrictTVar m (PublicPeerSelectionState addrNTN) - , llrnLdbFlavorArgs :: Complete LedgerDbFlavorArgs m + , llrnLdbFlavorArgs :: LedgerDbBackendArgs m blk -- ^ The flavor arguments } @@ -378,7 +375,7 @@ data , -- Ad hoc values to replace default ChainDB configurations srnSnapshotPolicyArgs :: SnapshotPolicyArgs , srnQueryBatchSize :: QueryBatchSize - , srnLedgerDbBackendArgs :: LedgerDbBackendArgs m + , srnLedgerDbBackendArgs :: LedgerDbBackendArgs m blk } {------------------------------------------------------------------------------- @@ -819,7 +816,7 @@ openChainDB :: (ChainDB.RelativeMountPoint -> SomeHasFS m) -> -- | Volatile FS, see 'NodeDatabasePaths' (ChainDB.RelativeMountPoint -> SomeHasFS m) -> - Complete LedgerDbFlavorArgs m -> + LedgerDbBackendArgs m blk -> -- | A set of default arguments (possibly modified from 'defaultArgs') Incomplete ChainDbArgs m blk -> -- | Customise the 'ChainDbArgs' @@ -1007,7 +1004,7 @@ stdLowLevelRunNodeArgsIO } $(SafeWildCards.fields 'StdRunNodeArgs) = do llrnBfcSalt <- stdBfcSaltIO - (lsmSalt, llrnRng) <- genWord64 <$> newStdGen + llrnRng <- newStdGen pure LowLevelRunNodeArgs { llrnBfcSalt @@ -1052,21 +1049,7 @@ stdLowLevelRunNodeArgsIO InFutureCheck.defaultClockSkew , llrnPublicPeerSelectionStateVar = Diffusion.dcPublicPeerSelectionVar srnDiffusionConfiguration - , llrnLdbFlavorArgs = - case srnLedgerDbBackendArgs of - V1LMDB args -> LedgerDbFlavorArgsV1 args - V2InMemory -> LedgerDbFlavorArgsV2 (V2.V2Args V2.InMemoryHandleArgs) - V2LSM path -> - LedgerDbFlavorArgsV2 - ( V2.V2Args - ( V2.LSMHandleArgs - ( V2.LSMArgs - (mkFsPath $ splitDirectories path) - lsmSalt - (LSM.stdMkBlockIOFS (nonImmutableDbPath srnDatabasePath)) - ) - ) - ) + , llrnLdbFlavorArgs = srnLedgerDbBackendArgs } where networkMagic :: NetworkMagic diff --git a/ouroboros-consensus/changelog.d/20251010_121126_javier.sagredo_extract_2.md b/ouroboros-consensus/changelog.d/20251010_121126_javier.sagredo_extract_2.md new file mode 100644 index 0000000000..ea9d4b5b12 --- /dev/null +++ b/ouroboros-consensus/changelog.d/20251010_121126_javier.sagredo_extract_2.md @@ -0,0 +1,29 @@ + + + + + +### Breaking + +- Extracted `Ouroboros.Consensus.Storage.LedgerDB.V2.LSM` into a separate sub-library `ouroboros-consensus-lsm`. +- Extracted `Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB*` into a separate sub-library `ouroboros-consensus-lmdb`. +- Define `Ouroboros.Consensus.Storage.LedgerDB.V2.Backend.Backend` class that allow for interaction with backends mainly opening them, and define instances for all existing V2 backends. +- Define `Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Backend` class that allow for interaction with backends mainly opening them, and define instances for all existing V1 backends. +- Define `Ouroboros.Consensus.Storage.LedgerDB.APIStreamingBackend` class that allows for streaming in/out from a backend, and define instances for all existing backends. +- Delete `LedgerDbFlavorArgs`. Repurpose `LedgerDbBackendArgs` for the arguments needed by the `Backend` classes to initialize a backend, and expect it in `LedgerDbArgs`. +- Delete `V1.FlavorImplSpecificTrace` and `V2.FlavorImplSpecificTrace` and use `Backend(SomeBackendTrace)` for those. diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 71b3d4dab9..9396b428bb 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -251,19 +251,15 @@ library Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.InMemory - Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB - Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB.Bridge - Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB.Status Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog Ouroboros.Consensus.Storage.LedgerDB.V1.DiffSeq Ouroboros.Consensus.Storage.LedgerDB.V1.Forker Ouroboros.Consensus.Storage.LedgerDB.V1.Lock Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots Ouroboros.Consensus.Storage.LedgerDB.V2 - Ouroboros.Consensus.Storage.LedgerDB.V2.Args + Ouroboros.Consensus.Storage.LedgerDB.V2.Backend Ouroboros.Consensus.Storage.LedgerDB.V2.Forker Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory - Ouroboros.Consensus.Storage.LedgerDB.V2.LSM Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq Ouroboros.Consensus.Storage.PerasCertDB Ouroboros.Consensus.Storage.PerasCertDB.API @@ -304,7 +300,6 @@ library Ouroboros.Consensus.Util.Orphans Ouroboros.Consensus.Util.RedundantConstraints Ouroboros.Consensus.Util.STM - Ouroboros.Consensus.Util.StreamingLedgerTables Ouroboros.Consensus.Util.Time Ouroboros.Consensus.Util.Versioned @@ -316,13 +311,10 @@ library base16-bytestring, bimap >=0.4 && <0.6, binary >=0.8 && <0.11, - blockio, bytestring >=0.10 && <0.13, cardano-binary, cardano-crypto-class, cardano-ledger-core ^>=1.19, - cardano-lmdb >=0.4, - cardano-lmdb-simple ^>=0.8, cardano-prelude, cardano-slotting, cardano-strict-containers, @@ -337,7 +329,6 @@ library fs-api ^>=0.4, hashable, io-classes:{io-classes, si-timers, strict-mvar, strict-stm} ^>=1.8.0.1, - lsm-tree, measures, mempack, monoid-subclasses, @@ -379,6 +370,71 @@ library directory latex-svg-image +library ouroboros-consensus-lsm + import: common-lib + visibility: public + hs-source-dirs: src/ouroboros-consensus-lsm + exposed-modules: + Ouroboros.Consensus.Storage.LedgerDB.V2.LSM + + build-depends: + base >=4.14 && <4.22, + blockio, + containers >=0.5 && <0.8, + contra-tracer, + filepath, + fs-api ^>=0.4, + lsm-tree, + mempack, + mtl, + nothunks ^>=0.2, + ouroboros-consensus, + primitive, + random, + resource-registry ^>=0.1, + serialise ^>=0.2, + streaming, + text, + transformers, + vector ^>=0.13, + + build-depends: text >=1.2.5.0 && <2.2 + +library ouroboros-consensus-lmdb + import: common-lib + visibility: public + hs-source-dirs: src/ouroboros-consensus-lmdb + exposed-modules: + Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB + Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB.Bridge + Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB.Status + + build-depends: + base >=4.14 && <4.22, + bytestring >=0.10 && <0.13, + cardano-lmdb >=0.4, + cardano-lmdb-simple ^>=0.8, + cardano-slotting, + containers >=0.5 && <0.8, + contra-tracer, + directory, + filepath, + fs-api ^>=0.4, + io-classes ^>=1.8.0.1, + mempack, + mtl, + nothunks ^>=0.2, + ouroboros-consensus, + rawlock ^>=0.1.1, + resource-registry, + serialise ^>=0.2, + sop-core, + streaming, + temporary, + text, + + build-depends: text >=1.2.5.0 && <2.2 + library unstable-consensus-testlib import: common-lib visibility: public @@ -762,7 +818,7 @@ test-suite storage-test mempack, mtl, nothunks, - ouroboros-consensus, + ouroboros-consensus:{ouroboros-consensus, ouroboros-consensus-lmdb, ouroboros-consensus-lsm}, ouroboros-network-api, ouroboros-network-mock, ouroboros-network-protocols, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/LMDB.hs b/ouroboros-consensus/src/ouroboros-consensus-lmdb/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/LMDB.hs similarity index 81% rename from ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/LMDB.hs rename to ouroboros-consensus/src/ouroboros-consensus-lmdb/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/LMDB.hs index 919db97859..1a0044476d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/LMDB.hs +++ b/ouroboros-consensus/src/ouroboros-consensus-lmdb/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/LMDB.hs @@ -3,38 +3,46 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeData #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- | A 'BackingStore' implementation based on [LMDB](http://www.lmdb.tech/doc/). module Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB ( -- * Opening a database - LMDBLimits (LMDBLimits, lmdbMapSize, lmdbMaxDatabases, lmdbMaxReaders) - , newLMDBBackingStore - - -- * Errors + LMDB + , Backend (..) + , Args (LMDBBackingStoreArgs) + , LMDBLimits (LMDBLimits, lmdbMapSize, lmdbMaxDatabases, lmdbMaxReaders) + , mkLMDBArgs + + -- * Streaming + , YieldArgs (YieldLMDB) + , mkLMDBYieldArgs + , SinkArgs (SinkLMDB) + , mkLMDBSinkArgs + + -- * Exposed for testing , LMDBErr (..) - - -- * Internals exposed for @snapshot-converter@ - , DbSeqNo (..) - , LMDBMK (..) - , getDb - , initLMDBTable - , withDbSeqNoRWMaybeNull ) where -import Cardano.Slotting.Slot (SlotNo, WithOrigin (At)) +import Cardano.Slotting.Slot (WithOrigin (At)) import qualified Codec.Serialise as S (Serialise (..)) import qualified Control.Concurrent.Class.MonadSTM.TVar as IOLike import Control.Monad (forM_, unless, void, when) import qualified Control.Monad.Class.MonadSTM as IOLike import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans (lift) +import Control.ResourceRegistry import qualified Control.Tracer as Trace import Data.Bifunctor (first) import Data.Functor (($>), (<&>)) @@ -43,6 +51,7 @@ import Data.Map (Map) import qualified Data.Map.Strict as Map import Data.MemPack import Data.Proxy +import qualified Data.SOP.Dict as Dict import qualified Data.Set as Set import qualified Data.Text as Strict import qualified Database.LMDB.Simple as LMDB @@ -52,11 +61,17 @@ import qualified Database.LMDB.Simple.Internal as LMDB.Internal import qualified Database.LMDB.Simple.TransactionHandle as TrH import GHC.Generics (Generic) import GHC.Stack (HasCallStack) -import Ouroboros.Consensus.Ledger.Tables +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Ledger.Basics import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff +import Ouroboros.Consensus.Ledger.Tables.Utils (emptyLedgerTables) +import Ouroboros.Consensus.Storage.LedgerDB.API +import Ouroboros.Consensus.Storage.LedgerDB.Args import Ouroboros.Consensus.Storage.LedgerDB.Snapshots ( SnapshotBackend (..) ) +import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as V1 +import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API as API import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB.Bridge as Bridge import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB.Status @@ -70,10 +85,17 @@ import Ouroboros.Consensus.Util.IOLike , IOLike , MonadCatch (..) , MonadThrow (..) + , PrimState , bracket ) import Ouroboros.Consensus.Util.IndexedMemPack +import qualified Streaming as S +import qualified Streaming.Prelude as S +import System.Directory import qualified System.FS.API as FS +import System.FS.IO +import qualified System.FilePath as FilePath +import System.IO.Temp {------------------------------------------------------------------------------- Database definition @@ -793,3 +815,187 @@ prettyPrintLMDBErr = \case LMDBErrNotADir path -> "The path " <> show path <> " should be a directory but it is a file instead." LMDBErrClosed -> "The database has been closed." + +{------------------------------------------------------------------------------- + Backend +-------------------------------------------------------------------------------} + +type data LMDB + +instance + ( HasLedgerTables l + , MonadIO m + , IOLike m + , MemPackIdx l EmptyMK ~ l EmptyMK + ) => + Backend m LMDB l + where + data Args m LMDB + = LMDBBackingStoreArgs FilePath LMDBLimits (Dict.Dict MonadIOPrim m) + data Trace m LMDB + = OnDiskBackingStoreInitialise LMDB.Limits + | OnDiskBackingStoreTrace BackingStoreTrace + deriving (Eq, Show) + + isRightBackendForSnapshot _ _ UTxOHDLMDBSnapshot = True + isRightBackendForSnapshot _ _ _ = False + + newBackingStoreInitialiser trcr (LMDBBackingStoreArgs fs limits Dict.Dict) = + newLMDBBackingStore + (SomeBackendTrace . OnDiskBackingStoreTrace >$< trcr) + limits + (LiveLMDBFS $ FS.SomeHasFS $ ioHasFS $ FS.MountPoint fs) + +-- | Create arguments for initializing the LedgerDB using the LMDB backend. +mkLMDBArgs :: + ( MonadIOPrim m + , HasLedgerTables (LedgerState blk) + , IOLike m + ) => + V1.FlushFrequency -> FilePath -> LMDBLimits -> a -> (LedgerDbBackendArgs m blk, a) +mkLMDBArgs flushing lmdbPath limits = + (,) $ + LedgerDbBackendArgsV1 $ + V1.V1Args flushing $ + SomeBackendArgs $ + LMDBBackingStoreArgs lmdbPath limits Dict.Dict + +class (MonadIO m, PrimState m ~ PrimState IO) => MonadIOPrim m +instance (MonadIO m, PrimState m ~ PrimState IO) => MonadIOPrim m + +{------------------------------------------------------------------------------- + Streaming +-------------------------------------------------------------------------------} + +instance (Ord (TxIn l), GetTip l, Monad m) => StreamingBackend m LMDB l where + data SinkArgs m LMDB l + = SinkLMDB + -- \| Chunk size + Int + -- \| bsWrite + ( SlotNo -> + (l EmptyMK, l EmptyMK) -> + LedgerTables l DiffMK -> + m () + ) + (l EmptyMK -> m ()) + + data YieldArgs m LMDB l + = YieldLMDB + Int + (LedgerBackingStoreValueHandle m l) + + yield _ (YieldLMDB chunkSize valueHandle) = yieldLmdbS chunkSize valueHandle + sink _ (SinkLMDB chunkSize write copy) = sinkLmdbS chunkSize write copy + +sinkLmdbS :: + forall m l. + (Ord (TxIn l), GetTip l, Monad m) => + Int -> + (SlotNo -> (l EmptyMK, l EmptyMK) -> LedgerTables l DiffMK -> m ()) -> + (l EmptyMK -> m ()) -> + Sink m l +sinkLmdbS writeChunkSize bs copyTo hint s = do + r <- go writeChunkSize mempty s + lift $ copyTo hint + pure (fmap (,Nothing) r) + where + sl = withOrigin (error "unreachable") id $ pointSlot $ getTip hint + + go 0 m s' = do + lift $ bs sl (hint, hint) (LedgerTables $ DiffMK $ Diff.fromMapInserts m) + go writeChunkSize mempty s' + go n m s' = do + mbs <- S.uncons s' + case mbs of + Nothing -> do + lift $ bs sl (hint, hint) (LedgerTables $ DiffMK $ Diff.fromMapInserts m) + S.effects s' + Just ((k, v), s'') -> + go (n - 1) (Map.insert k v m) s'' + +yieldLmdbS :: + Monad m => + Int -> + LedgerBackingStoreValueHandle m l -> + Yield m l +yieldLmdbS readChunkSize bsvh hint k = do + r <- k (go (RangeQuery Nothing readChunkSize)) + lift $ S.effects r + where + go p = do + (LedgerTables (ValuesMK values), mx) <- lift $ S.lift $ bsvhRangeRead bsvh hint p + case mx of + Nothing -> pure $ pure Nothing + Just x -> do + S.each $ Map.toList values + go (RangeQuery (Just . LedgerTables . KeysMK $ Set.singleton x) readChunkSize) + +-- | Create Yield args for LMDB +mkLMDBYieldArgs :: + forall l. + ( HasCallStack + , HasLedgerTables l + , MemPackIdx l EmptyMK ~ l EmptyMK + ) => + FilePath -> + LMDBLimits -> + l EmptyMK -> + ResourceRegistry IO -> + IO (YieldArgs IO LMDB l) +mkLMDBYieldArgs fp limits hint reg = do + let (dbPath, snapName) = FilePath.splitFileName fp + tempDir <- getCanonicalTemporaryDirectory + let lmdbTemp = tempDir FilePath. "lmdb_streaming_in" + removePathForcibly lmdbTemp + _ <- + allocate + reg + (\_ -> createDirectory lmdbTemp) + (\_ -> removePathForcibly lmdbTemp) + (_, bs) <- + allocate + reg + ( \_ -> do + newLMDBBackingStore + Trace.nullTracer + limits + (LiveLMDBFS $ FS.SomeHasFS $ ioHasFS $ FS.MountPoint lmdbTemp) + (SnapshotsFS $ FS.SomeHasFS $ ioHasFS $ FS.MountPoint dbPath) + (InitFromCopy hint (FS.mkFsPath [snapName])) + ) + bsClose + (_, bsvh) <- allocate reg (\_ -> bsValueHandle bs) bsvhClose + pure (YieldLMDB 1000 bsvh) + +-- | Create Sink args for LMDB +mkLMDBSinkArgs :: + forall l. + ( HasCallStack + , HasLedgerTables l + , MemPackIdx l EmptyMK ~ l EmptyMK + ) => + FilePath -> + LMDBLimits -> + l EmptyMK -> + ResourceRegistry IO -> + IO (SinkArgs IO LMDB l) +mkLMDBSinkArgs fp limits hint reg = do + let (snapDir, snapName) = FilePath.splitFileName fp + tempDir <- getCanonicalTemporaryDirectory + let lmdbTemp = tempDir FilePath. "lmdb_streaming_out" + removePathForcibly lmdbTemp + _ <- allocate reg (\_ -> createDirectory lmdbTemp) (\_ -> removePathForcibly lmdbTemp) + (_, bs) <- + allocate + reg + ( \_ -> + newLMDBBackingStore + Trace.nullTracer + limits + (LiveLMDBFS $ FS.SomeHasFS $ ioHasFS $ FS.MountPoint lmdbTemp) + (SnapshotsFS $ FS.SomeHasFS $ ioHasFS $ FS.MountPoint snapDir) + (InitFromValues (At 0) hint emptyLedgerTables) + ) + bsClose + pure $ SinkLMDB 1000 (bsWrite bs) (\h -> bsCopy bs h (FS.mkFsPath [snapName, "tables"])) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/LMDB/Bridge.hs b/ouroboros-consensus/src/ouroboros-consensus-lmdb/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/LMDB/Bridge.hs similarity index 100% rename from ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/LMDB/Bridge.hs rename to ouroboros-consensus/src/ouroboros-consensus-lmdb/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/LMDB/Bridge.hs diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/LMDB/Status.hs b/ouroboros-consensus/src/ouroboros-consensus-lmdb/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/LMDB/Status.hs similarity index 100% rename from ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/LMDB/Status.hs rename to ouroboros-consensus/src/ouroboros-consensus-lmdb/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/LMDB/Status.hs diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs b/ouroboros-consensus/src/ouroboros-consensus-lsm/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs similarity index 65% rename from ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs rename to ouroboros-consensus/src/ouroboros-consensus-lsm/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs index 471af89dd0..3dd12867d2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs +++ b/ouroboros-consensus/src/ouroboros-consensus-lsm/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs @@ -1,53 +1,42 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeData #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} -- Needed for @NoThunks (Table m k v b)@ {-# OPTIONS_GHC -Wno-orphans #-} -- | Implementation of the 'LedgerTablesHandle' interface with LSM trees. module Ouroboros.Consensus.Storage.LedgerDB.V2.LSM - ( -- * LedgerTablesHandle - newLSMLedgerTablesHandle - , tableFromValuesMK - , UTxOTable - - -- * Snapshots - , loadSnapshot - , snapshotManager - - -- * Re-exports - , LSM.Entry (..) - , LSM.RawBytes (..) - , LSM.Salt - , Session - , LSM.openSession - , LSM.closeSession + ( -- * Backend API + LSM + , Backend (..) + , Args (LSMArgs) + , mkLSMArgs , stdMkBlockIOFS - -- * snapshot-converter - , implTakeSnapshot - , LSM.withNewSession - , toTxInBytes - , toTxOutBytes - , LSM.newSession - , LSM.toSnapshotName - , LSM.SnapshotLabel (LSM.SnapshotLabel) - , LSM.openTableFromSnapshot - , LSM.closeTable - , LSM.listSnapshots + -- * Streaming + , YieldArgs (YieldLSM) + , mkLSMYieldArgs + , SinkArgs (SinkLSM) + , mkLSMSinkArgs + + -- * Exported for tests + , LSM.Salt + , SomeHasFSAndBlockIO (..) ) where import Codec.Serialise (decode) @@ -65,16 +54,18 @@ import Data.MemPack import qualified Data.Primitive.ByteArray as PBA import qualified Data.Set as Set import Data.String (fromString) +import qualified Data.Text as T import qualified Data.Text as Text +import Data.Typeable import qualified Data.Vector as V import qualified Data.Vector.Mutable as VM import qualified Data.Vector.Primitive as VP import Data.Void -import Database.LSMTree (Session, Table) +import Database.LSMTree (Salt, Session, Table) import qualified Database.LSMTree as LSM +import GHC.Generics import NoThunks.Class import Ouroboros.Consensus.Block -import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsProtocol @@ -83,18 +74,20 @@ import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Storage.LedgerDB.API import Ouroboros.Consensus.Storage.LedgerDB.Args import Ouroboros.Consensus.Storage.LedgerDB.Snapshots -import Ouroboros.Consensus.Storage.LedgerDB.TraceEvent -import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 +import Ouroboros.Consensus.Storage.LedgerDB.V2.Backend import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq import Ouroboros.Consensus.Util (chunks) -import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.CRC import Ouroboros.Consensus.Util.Enclose import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.IndexedMemPack +import qualified Streaming as S +import qualified Streaming.Prelude as S import System.FS.API import qualified System.FS.BlockIO.API as BIO import System.FS.BlockIO.IO +import System.FilePath (splitDirectories, splitFileName) +import System.Random import Prelude hiding (read) -- | Type alias for convenience @@ -173,12 +166,12 @@ newLSMLedgerTablesHandle :: , HasLedgerTables l , IndexedMemPack (l EmptyMK) (TxOut l) ) => - Tracer m V2.FlavorImplSpecificTrace -> + Tracer m LedgerDBV2Trace -> ResourceRegistry m -> (ResourceKey m, UTxOTable m) -> m (LedgerTablesHandle m l) newLSMLedgerTablesHandle tracer rr (resKey, t) = do - traceWith tracer V2.TraceLedgerTablesHandleCreate + traceWith tracer TraceLedgerTablesHandleCreate pure LedgerTablesHandle { close = implClose resKey @@ -209,7 +202,7 @@ implDuplicate :: ) => ResourceRegistry m -> UTxOTable m -> - Tracer m V2.FlavorImplSpecificTrace -> + Tracer m LedgerDBV2Trace -> m (LedgerTablesHandle m l) implDuplicate rr t tracer = do table <- @@ -217,7 +210,7 @@ implDuplicate rr t tracer = do rr (\_ -> LSM.duplicate t) ( \t' -> do - traceWith tracer V2.TraceLedgerTablesHandleClose + traceWith tracer TraceLedgerTablesHandleClose LSM.closeTable t' ) newLSMLedgerTablesHandle tracer rr table @@ -330,21 +323,6 @@ implTakeHandleSnapshot t _ snapshotName = do -------------------------------------------------------------------------------} snapshotManager :: - ( IOLike m - , LedgerDbSerialiseConstraints blk - , LedgerSupportsProtocol blk - ) => - Session m -> - Complete LedgerDbArgs m blk -> - SnapshotManager m m blk (StateRef m (ExtLedgerState blk)) -snapshotManager session args = - snapshotManager' - session - (configCodec . getExtLedgerCfg . ledgerDbCfg $ lgrConfig args) - (LedgerDBSnapshotEvent >$< lgrTracer args) - (lgrHasFS args) - -snapshotManager' :: ( IOLike m , LedgerDbSerialiseConstraints blk , LedgerSupportsProtocol blk @@ -354,7 +332,7 @@ snapshotManager' :: Tracer m (TraceSnapshotEvent blk) -> SomeHasFS m -> SnapshotManager m m blk (StateRef m (ExtLedgerState blk)) -snapshotManager' session ccfg tracer fs = +snapshotManager session ccfg tracer fs = SnapshotManager { listSnapshots = defaultListSnapshots fs , deleteSnapshot = implDeleteSnapshot session fs tracer @@ -441,7 +419,7 @@ loadSnapshot :: , LedgerSupportsProtocol blk , IOLike m ) => - Tracer m V2.FlavorImplSpecificTrace -> + Tracer m LedgerDBV2Trace -> ResourceRegistry m -> CodecConfig blk -> SomeHasFS m -> @@ -475,7 +453,7 @@ loadSnapshot tracer rr ccfg fs session ds = (LSM.SnapshotLabel $ Text.pack $ "UTxO table") ) ( \t -> do - traceWith tracer V2.TraceLedgerTablesHandleClose + traceWith tracer TraceLedgerTablesHandleClose LSM.closeTable t ) Monad.when @@ -491,7 +469,7 @@ loadSnapshot tracer rr ccfg fs session ds = tableFromValuesMK :: forall m l. (IOLike m, IndexedMemPack (l EmptyMK) (TxOut l), MemPack (TxIn l)) => - Tracer m V2.FlavorImplSpecificTrace -> + Tracer m LedgerDBV2Trace -> ResourceRegistry m -> Session m -> l EmptyMK -> @@ -505,7 +483,7 @@ tableFromValuesMK tracer rr session st (LedgerTables (ValuesMK values)) = do LSM.newTableWith (LSM.defaultTableConfig{LSM.confFencePointerIndex = LSM.OrdinaryIndex}) session ) ( \tb -> do - traceWith tracer V2.TraceLedgerTablesHandleClose + traceWith tracer TraceLedgerTablesHandleClose LSM.closeTable tb ) mapM_ (go table) $ chunks 1000 $ Map.toList values @@ -521,11 +499,249 @@ tableFromValuesMK tracer rr session st (LedgerTables (ValuesMK values)) = do -------------------------------------------------------------------------------} stdMkBlockIOFS :: - FilePath -> ResourceRegistry IO -> IO (ResourceKey IO, V2.SomeHasFSAndBlockIO IO) + FilePath -> ResourceRegistry IO -> IO (ResourceKey IO, SomeHasFSAndBlockIO IO) stdMkBlockIOFS fastStoragePath rr = do (rk1, bio) <- allocate rr (\_ -> ioHasBlockIO (MountPoint fastStoragePath) defaultIOCtxParams) (BIO.close . snd) - pure (rk1, uncurry V2.SomeHasFSAndBlockIO bio) + pure (rk1, uncurry SomeHasFSAndBlockIO bio) + +{------------------------------------------------------------------------------- + Backend +-------------------------------------------------------------------------------} + +type data LSM + +-- | Create arguments for initializing the LedgerDB using the LSM-trees backend. +mkLSMArgs :: + ( LedgerSupportsProtocol blk + , LedgerDbSerialiseConstraints blk + ) => + Proxy blk -> FilePath -> FilePath -> StdGen -> (LedgerDbBackendArgs IO blk, StdGen) +mkLSMArgs _ fp fastStorage gen = + let (lsmSalt, gen') = genWord64 gen + in ( LedgerDbBackendArgsV2 $ + SomeBackendArgs $ + LSMArgs (mkFsPath $ splitDirectories fp) lsmSalt (stdMkBlockIOFS fastStorage) + , gen' + ) + +instance + ( LedgerSupportsProtocol blk + , IOLike m + , LedgerDbSerialiseConstraints blk + , HasLedgerTables (LedgerState blk) + ) => + Backend m LSM blk + where + data Args m LSM + = LSMArgs + FsPath + -- \^ The file path relative to the fast storage directory in which the LSM + -- trees database will be located. + Salt + (ResourceRegistry m -> m (ResourceKey m, SomeHasFSAndBlockIO m)) + + data Resources m LSM = LSMResources + { sessionKey :: !(ResourceKey m) + , sessionResource :: !(Session m) + , blockIOKey :: !(ResourceKey m) + } + deriving Generic + + data Trace m LSM + = LSMTreeTrace !LSM.LSMTreeTrace + deriving Show + + mkResources _ trcr (LSMArgs path salt mkFS) reg _ = do + (rk1, SomeHasFSAndBlockIO fs blockio) <- mkFS reg + session <- + allocate + reg + ( \_ -> + LSM.openSession + (BackendTrace . SomeBackendTrace . LSMTreeTrace >$< trcr) + fs + blockio + salt + path + ) + LSM.closeSession + pure (LSMResources (fst session) (snd session) rk1) + + releaseResources _ l = do + Monad.void . release . sessionKey $ l + Monad.void . release . blockIOKey $ l + + newHandleFromSnapshot trcr reg ccfg shfs res ds = do + loadSnapshot trcr reg ccfg shfs (sessionResource res) ds + + newHandleFromValues trcr reg res st = do + table <- + tableFromValuesMK trcr reg (sessionResource res) (forgetLedgerTables st) (ltprj st) + newLSMLedgerTablesHandle trcr reg table + + snapshotManager _ res = Ouroboros.Consensus.Storage.LedgerDB.V2.LSM.snapshotManager (sessionResource res) + +instance + ( MemPack (TxIn l) + , IndexedMemPack (l EmptyMK) (TxOut l) + , IOLike m + ) => + StreamingBackend m LSM l + where + data YieldArgs m LSM l + = -- \| Yield an LSM snapshot + YieldLSM + Int + (LedgerTablesHandle m l) + + data SinkArgs m LSM l + = SinkLSM + -- \| Chunk size + Int + -- \| Snap name + String + (Session m) + + yield _ (YieldLSM chunkSize hdl) = yieldLsmS chunkSize hdl + + sink _ (SinkLSM chunkSize snapName session) = sinkLsmS chunkSize snapName session + +data SomeHasFSAndBlockIO m where + SomeHasFSAndBlockIO :: + (Eq h, Typeable h) => HasFS m h -> BIO.HasBlockIO m h -> SomeHasFSAndBlockIO m + +instance IOLike m => NoThunks (Resources m LSM) where + wNoThunks ctxt (LSMResources sk _ bk) = wNoThunks ctxt sk >> wNoThunks ctxt bk + +{------------------------------------------------------------------------------- + Streaming +-------------------------------------------------------------------------------} + +yieldLsmS :: + Monad m => + Int -> + LedgerTablesHandle m l -> + Yield m l +yieldLsmS readChunkSize tb hint k = do + r <- k (go (Nothing, readChunkSize)) + lift $ S.effects r + where + go p = do + (LedgerTables (ValuesMK values), mx) <- lift $ S.lift $ readRange tb hint p + if Map.null values + then pure $ pure Nothing + else do + S.each $ Map.toList values + go (mx, readChunkSize) + +sinkLsmS :: + forall m l. + ( MonadAsync m + , MonadMVar m + , MonadThrow (STM m) + , MonadMask m + , MonadST m + , MonadEvaluate m + , MemPack (TxIn l) + , IndexedMemPack (l EmptyMK) (TxOut l) + ) => + Int -> + String -> + Session m -> + Sink m l +sinkLsmS writeChunkSize snapName session st s = do + tb :: UTxOTable m <- lift $ LSM.newTable session + r <- go tb writeChunkSize mempty s + lift $ + LSM.saveSnapshot + (LSM.toSnapshotName snapName) + (LSM.SnapshotLabel $ T.pack "UTxO table") + tb + lift $ LSM.closeTable tb + pure (fmap (,Nothing) r) + where + go tb 0 m s' = do + lift $ + LSM.inserts tb $ + V.fromList [(toTxInBytes (Proxy @l) k, toTxOutBytes st v, Nothing) | (k, v) <- m] + go tb writeChunkSize mempty s' + go tb n m s' = do + mbs <- S.uncons s' + case mbs of + Nothing -> do + lift $ + LSM.inserts tb $ + V.fromList + [(toTxInBytes (Proxy @l) k, toTxOutBytes st v, Nothing) | (k, v) <- m] + S.effects s' + Just (item, s'') -> go tb (n - 1) (item : m) s'' + +-- | Create Yield arguments for LSM +mkLSMYieldArgs :: + ( IOLike m + , HasLedgerTables l + , IndexedMemPack (l EmptyMK) (TxOut l) + ) => + -- | The filepath in which the LSM database lives. Must not have a trailing slash! + FilePath -> + -- | The complete name of the snapshot to open, so @[_]@. + String -> + -- | Usually 'stdMkBlockIOFS' + (FilePath -> ResourceRegistry m -> m (a, SomeHasFSAndBlockIO m)) -> + -- | Usually 'newStdGen' + (m StdGen) -> + l EmptyMK -> + ResourceRegistry m -> + m (YieldArgs m LSM l) +mkLSMYieldArgs fp snapName mkFS mkGen _ reg = do + (_, SomeHasFSAndBlockIO hasFS blockIO) <- mkFS fp reg + salt <- fst . genWord64 <$> mkGen + (_, session) <- + allocate reg (\_ -> LSM.openSession nullTracer hasFS blockIO salt (mkFsPath [])) LSM.closeSession + tb <- + allocate + reg + ( \_ -> + LSM.openTableFromSnapshot + session + (LSM.toSnapshotName snapName) + (LSM.SnapshotLabel $ T.pack "UTxO table") + ) + LSM.closeTable + YieldLSM 1000 <$> newLSMLedgerTablesHandle nullTracer reg tb + +-- | Create Sink arguments for LSM +mkLSMSinkArgs :: + IOLike m => + -- | The filepath in which the LSM database should be opened. Must not have a trailing slash! + FilePath -> + -- | The complete name of the snapshot to be created, so @[_]@. + String -> + -- | Usually 'stdMkBlockIOFS' + (FilePath -> ResourceRegistry m -> m (a, SomeHasFSAndBlockIO m)) -> + -- | Usually 'newStdGen' + (m StdGen) -> + l EmptyMK -> + ResourceRegistry m -> + m (SinkArgs m LSM l) +mkLSMSinkArgs + (splitFileName -> (fp, lsmDir)) + snapName + mkFS + mkGen + _ + reg = + do + (_, SomeHasFSAndBlockIO hasFS blockIO) <- mkFS fp reg + removeDirectoryRecursive hasFS lsmFsPath + createDirectory hasFS lsmFsPath + salt <- fst . genWord64 <$> mkGen + (_, session) <- + allocate reg (\_ -> LSM.newSession nullTracer hasFS blockIO salt lsmFsPath) LSM.closeSession + pure (SinkLSM 1000 snapName session) + where + lsmFsPath = mkFsPath [lsmDir] diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs index db793c8f0d..a5b95d537d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs @@ -29,6 +29,7 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API ( GetLoEFragment @@ -38,9 +39,11 @@ import Ouroboros.Consensus.Storage.ChainDB.Impl.Types ( TraceEvent (..) ) import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB -import Ouroboros.Consensus.Storage.LedgerDB (LedgerDbFlavorArgs) +import Ouroboros.Consensus.Storage.LedgerDB (LedgerDbBackendArgs) import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB import Ouroboros.Consensus.Storage.LedgerDB.Snapshots +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Backend as LedgerDB +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike @@ -131,13 +134,17 @@ defaultSpecificArgs = -- and must therefore be set explicitly. defaultArgs :: forall m blk. - Monad m => + ( IOLike m + , LedgerDB.LedgerDbSerialiseConstraints blk + , LedgerSupportsProtocol blk + , LedgerDB.LedgerSupportsInMemoryLedgerDB (LedgerState blk) + ) => Incomplete ChainDbArgs m blk defaultArgs = ChainDbArgs ImmutableDB.defaultArgs VolatileDB.defaultArgs - LedgerDB.defaultArgs + (LedgerDB.defaultArgs $ LedgerDB.SomeBackendArgs InMemory.InMemArgs) defaultSpecificArgs ensureValidateAll :: @@ -169,7 +176,7 @@ completeChainDbArgs :: (RelativeMountPoint -> SomeHasFS m) -> -- | Volatile FS, see 'NodeDatabasePaths' (RelativeMountPoint -> SomeHasFS m) -> - Complete LedgerDbFlavorArgs m -> + LedgerDbBackendArgs m blk -> -- | A set of incomplete arguments, possibly modified wrt @defaultArgs@ Incomplete ChainDbArgs m blk -> Complete ChainDbArgs m blk @@ -206,7 +213,7 @@ completeChainDbArgs LedgerDB.configLedgerDb cdbsTopLevelConfig (LedgerDB.ledgerDbCfgComputeLedgerEvents $ LedgerDB.lgrConfig (cdbLgrDbArgs defArgs)) - , LedgerDB.lgrFlavorArgs = flavorArgs + , LedgerDB.lgrBackendArgs = flavorArgs , LedgerDB.lgrRegistry = registry } , cdbsArgs = diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs index a16e674b3d..8ac0f6db53 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs @@ -83,7 +83,7 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Query as Query import Ouroboros.Consensus.Storage.ChainDB.Impl.Types import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB) import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB -import Ouroboros.Consensus.Storage.LedgerDB +import Ouroboros.Consensus.Storage.LedgerDB hiding (yield) import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB import Ouroboros.Consensus.Storage.VolatileDB (VolatileDB) import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs index e25cd9eb15..cb01fe8a8d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs @@ -1,9 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Ouroboros.Consensus.Storage.LedgerDB ( -- * API @@ -17,11 +15,12 @@ module Ouroboros.Consensus.Storage.LedgerDB , openDBInternal ) where -import Control.ResourceRegistry import Data.Functor.Contravariant ((>$<)) import Data.Word import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Abstract +import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Storage.ImmutableDB.Stream @@ -33,9 +32,7 @@ import Ouroboros.Consensus.Storage.LedgerDB.TraceEvent import qualified Ouroboros.Consensus.Storage.LedgerDB.V1 as V1 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots as V1 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2 as V2 -import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 -import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory -import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM +import Ouroboros.Consensus.Storage.LedgerDB.V2.Backend import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.IOLike @@ -70,46 +67,35 @@ openDB stream replayGoal getBlock - getVolatileSuffix = case lgrFlavorArgs args of - LedgerDbFlavorArgsV1 bss -> - let snapManager = V1.snapshotManager args - initDb = - V1.mkInitDb - args - bss - getBlock - snapManager - getVolatileSuffix - in doOpenDB args initDb snapManager stream replayGoal - LedgerDbFlavorArgsV2 bss -> do - (snapManager, bss') <- case bss of - V2.V2Args V2.InMemoryHandleArgs -> pure (InMemory.snapshotManager args, V2.InMemoryHandleEnv) - V2.V2Args (V2.LSMHandleArgs (V2.LSMArgs path salt mkFS)) -> do - (rk1, V2.SomeHasFSAndBlockIO fs blockio) <- mkFS (lgrRegistry args) - session <- - allocate - (lgrRegistry args) - ( \_ -> - LSM.openSession - (LedgerDBFlavorImplEvent . FlavorImplSpecificTraceV2 . V2.LSMTrace >$< lgrTracer args) - fs - blockio - salt - path - ) - LSM.closeSession - pure - ( LSM.snapshotManager (snd session) args - , V2.LSMHandleEnv (V2.LSMResources (fst session) (snd session) rk1) - ) - let initDb = - V2.mkInitDb - args - bss' - getBlock - snapManager - getVolatileSuffix - doOpenDB args initDb snapManager stream replayGoal + getVolatileSuffix = + case lgrBackendArgs args of + LedgerDbBackendArgsV1 bss -> + let snapManager = V1.snapshotManager args + initDb = + V1.mkInitDb + args + bss + getBlock + snapManager + getVolatileSuffix + in doOpenDB args initDb snapManager stream replayGoal + LedgerDbBackendArgsV2 (SomeBackendArgs bArgs) -> do + res <- + mkResources + (Proxy @blk) + (LedgerDBFlavorImplEvent . FlavorImplSpecificTraceV2 >$< lgrTracer args) + bArgs + (lgrRegistry args) + (lgrHasFS args) + let snapManager = + snapshotManager + (Proxy @blk) + res + (configCodec . getExtLedgerCfg . ledgerDbCfg $ lgrConfig args) + (LedgerDBSnapshotEvent >$< lgrTracer args) + (lgrHasFS args) + let initDb = V2.mkInitDb args getBlock snapManager getVolatileSuffix res + doOpenDB args initDb snapManager stream replayGoal {------------------------------------------------------------------------------- Opening a LedgerDB diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs index 7a9891e1f2..cc26e2f187 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs @@ -6,12 +6,8 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -154,22 +150,32 @@ module Ouroboros.Consensus.Storage.LedgerDB.API -- * Snapshots , SnapCounters (..) + -- * Streaming + , StreamingBackend (..) + , Yield + , Sink + , Decoders (..) + -- * Testing , TestInternals (..) , TestInternals' , WhereToTakeSnapshot (..) ) where +import Codec.CBOR.Decoding +import Codec.CBOR.Read import Codec.Serialise import qualified Control.Monad as Monad import Control.Monad.Class.MonadTime.SI import Control.Monad.Except import Control.ResourceRegistry import Control.Tracer +import Data.ByteString (ByteString) import Data.Functor.Contravariant ((>$<)) import Data.Kind import qualified Data.Map.Strict as Map import Data.MemPack +import Data.Proxy import Data.Set (Set) import Data.Void (absurd) import Data.Word @@ -195,6 +201,8 @@ import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.IndexedMemPack import Ouroboros.Network.Block import Ouroboros.Network.Protocol.LocalStateQuery.Type +import Streaming +import System.FS.CRC {------------------------------------------------------------------------------- Main API @@ -797,3 +805,41 @@ data LedgerDbPrune -- slot. LedgerDbPruneBeforeSlot SlotNo deriving Show + +{------------------------------------------------------------------------------- + Streaming +-------------------------------------------------------------------------------} + +-- | A backend that supports streaming the ledger tables +class StreamingBackend m backend l where + data YieldArgs m backend l + + data SinkArgs m backend l + + yield :: Proxy backend -> YieldArgs m backend l -> Yield m l + + sink :: Proxy backend -> SinkArgs m backend l -> Sink m l + +type Yield m l = + l EmptyMK -> + ( ( Stream + (Of (TxIn l, TxOut l)) + (ExceptT DeserialiseFailure m) + (Stream (Of ByteString) m (Maybe CRC)) -> + ExceptT DeserialiseFailure m (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)) + ) + ) -> + ExceptT DeserialiseFailure m (Maybe CRC, Maybe CRC) + +type Sink m l = + l EmptyMK -> + Stream + (Of (TxIn l, TxOut l)) + (ExceptT DeserialiseFailure m) + (Stream (Of ByteString) m (Maybe CRC)) -> + ExceptT DeserialiseFailure m (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)) + +data Decoders l + = Decoders + (forall s. Decoder s (TxIn l)) + (forall s. Decoder s (TxOut l)) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs index cc1d6367ed..773ac0b919 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs @@ -1,25 +1,16 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -- | Arguments for LedgerDB initialization. module Ouroboros.Consensus.Storage.LedgerDB.Args ( LedgerDbArgs (..) , LedgerDbBackendArgs (..) - , LedgerDbFlavorArgs (..) , QueryBatchSize (..) , defaultArgs , defaultQueryBatchSize @@ -44,21 +35,13 @@ import Ouroboros.Consensus.Storage.LedgerDB.API import Ouroboros.Consensus.Storage.LedgerDB.Snapshots import Ouroboros.Consensus.Storage.LedgerDB.TraceEvent import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as V1 -import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Backend as V2 import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike import Ouroboros.Network.AnchoredSeq (AnchoredSeq) import qualified Ouroboros.Network.AnchoredSeq as AS import System.FS.API -data LedgerDbBackendArgs m - = V1LMDB (Complete V1.LedgerDbFlavorArgs m) - | V2InMemory - | V2LSM - -- | The filepath **relative to the fast storage device** in which we will - -- open/create the LSM-tree database. - FilePath - {------------------------------------------------------------------------------- Arguments -------------------------------------------------------------------------------} @@ -75,7 +58,7 @@ data LedgerDbArgs f m blk = LedgerDbArgs , lgrHasFS :: HKD f (SomeHasFS m) , lgrConfig :: LedgerDbCfgF f (ExtLedgerState blk) , lgrTracer :: Tracer m (TraceEvent blk) - , lgrFlavorArgs :: LedgerDbFlavorArgs f m + , lgrBackendArgs :: LedgerDbBackendArgs m blk , lgrRegistry :: HKD f (ResourceRegistry m) , lgrQueryBatchSize :: QueryBatchSize , lgrStartSnapshot :: Maybe DiskSnapshot @@ -87,8 +70,9 @@ data LedgerDbArgs f m blk = LedgerDbArgs -- | Default arguments defaultArgs :: Applicative m => + V2.SomeBackendArgs m blk -> Incomplete LedgerDbArgs m blk -defaultArgs = +defaultArgs backendArgs = LedgerDbArgs { lgrSnapshotPolicyArgs = defaultSnapshotPolicyArgs , lgrGenesis = NoDefault @@ -98,24 +82,24 @@ defaultArgs = , lgrTracer = nullTracer , -- This value is the closest thing to a pre-UTxO-HD node, and as such it -- will be the default for end-users. - lgrFlavorArgs = LedgerDbFlavorArgsV2 (V2.V2Args V2.InMemoryHandleArgs) + lgrBackendArgs = LedgerDbBackendArgsV2 backendArgs , lgrRegistry = NoDefault , lgrStartSnapshot = Nothing } -data LedgerDbFlavorArgs f m - = LedgerDbFlavorArgsV1 (V1.LedgerDbFlavorArgs f m) - | LedgerDbFlavorArgsV2 (V2.LedgerDbFlavorArgs f m) +data LedgerDbBackendArgs m blk + = LedgerDbBackendArgsV1 (V1.LedgerDbBackendArgs m (ExtLedgerState blk)) + | LedgerDbBackendArgsV2 (V2.SomeBackendArgs m blk) {------------------------------------------------------------------------------- QueryBatchSize -------------------------------------------------------------------------------} --- | The /maximum/ number of keys to read in a backing store range query. +-- | The /maximum/ number of keys to read in a forker range query. -- -- When performing a ledger state query that involves on-disk parts of the -- ledger state, we might have to read ranges of key-value pair data (e.g., --- UTxO) from disk using backing store range queries. Instead of reading all +-- UTxO) from disk using forker range queries. Instead of reading all -- data in one go, we read it in batches. 'QueryBatchSize' determines the size -- of these batches. -- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/TraceEvent.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/TraceEvent.hs index 1bc193cd87..77b3d040ad 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/TraceEvent.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/TraceEvent.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PolyKinds #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Storage.LedgerDB.TraceEvent ( FlavorImplSpecificTrace (..) @@ -17,15 +15,15 @@ import Ouroboros.Consensus.Storage.LedgerDB.API import Ouroboros.Consensus.Storage.LedgerDB.Forker import Ouroboros.Consensus.Storage.LedgerDB.Snapshots import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore as V1 -import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Backend as V2 {------------------------------------------------------------------------------- Tracing -------------------------------------------------------------------------------} data FlavorImplSpecificTrace - = FlavorImplSpecificTraceV1 V1.FlavorImplSpecificTrace - | FlavorImplSpecificTraceV2 V2.FlavorImplSpecificTrace + = FlavorImplSpecificTraceV1 V1.SomeBackendTrace + | FlavorImplSpecificTraceV2 V2.LedgerDBV2Trace deriving Show data TraceEvent blk @@ -36,5 +34,7 @@ data TraceEvent blk deriving Generic deriving instance - (StandardHash blk, InspectLedger blk) => + ( StandardHash blk + , InspectLedger blk + ) => Show (TraceEvent blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs index 13a9847273..16ea252583 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs @@ -1,16 +1,13 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -83,7 +80,7 @@ mkInitDb :: , LedgerSupportsLedgerDB blk ) => Complete LedgerDbArgs m blk -> - Complete V1.LedgerDbFlavorArgs m -> + V1.LedgerDbBackendArgs m (ExtLedgerState blk) -> ResolveBlock m blk -> SnapshotManagerV1 m blk -> GetVolatileSuffix m blk -> @@ -379,7 +376,6 @@ mkInternals :: ( IOLike m , LedgerDbSerialiseConstraints blk , LedgerSupportsProtocol blk - , ApplyBlock (ExtLedgerState blk) blk ) => LedgerDBHandle m (ExtLedgerState blk) blk -> SnapshotManagerV1 m blk -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Args.hs index 841f79cda3..e8d1bf505a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Args.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Args.hs @@ -1,28 +1,14 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Storage.LedgerDB.V1.Args - ( BackingStoreArgs (..) - , FlushFrequency (..) - , LedgerDbFlavorArgs (..) + ( FlushFrequency (..) + , LedgerDbBackendArgs (..) , shouldFlush ) where -import Control.Monad.IO.Class -import Control.Monad.Primitive -import qualified Data.SOP.Dict as Dict import Data.Word import GHC.Generics -import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB -import Ouroboros.Consensus.Util.Args +import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore -- | The number of blocks in the immutable part of the chain that we have to see -- before we flush the ledger tables to disk. See 'onDiskShouldFlush'. @@ -43,14 +29,7 @@ shouldFlush requestedFlushFrequency = case requestedFlushFrequency of DefaultFlushFrequency -> (>= 100) DisableFlushing -> const False -data LedgerDbFlavorArgs f m = V1Args +data LedgerDbBackendArgs m l = V1Args { v1FlushFrequency :: FlushFrequency - , v1BackendArgs :: BackingStoreArgs f m + , v1BackendArgs :: SomeBackendArgs m l } - -data BackingStoreArgs f m - = LMDBBackingStoreArgs FilePath (HKD f LMDBLimits) (Dict.Dict MonadIOPrim m) - | InMemoryBackingStoreArgs - -class (MonadIO m, PrimState m ~ PrimState IO) => MonadIOPrim m -instance (MonadIO m, PrimState m ~ PrimState IO) => MonadIOPrim m diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore.hs index 94cf2129ab..360c23e96c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -- | See "Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API" for the @@ -17,8 +15,6 @@ module Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore ( -- * API - -- - -- | Most of the documentation on the behaviour of the 'BackingStore' lives -- in this module. module Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API @@ -28,29 +24,18 @@ module Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore , restoreBackingStore -- * Tracing - , FlavorImplSpecificTrace (..) - , FlavorImplSpecificTraceInMemory (..) - , FlavorImplSpecificTraceOnDisk (..) - - -- * Testing - , newBackingStoreInitialiser + , SomeBackendTrace (..) + , SomeBackendArgs (..) + , Backend (..) ) where import Cardano.Slotting.Slot import Control.Tracer -import Data.Functor.Contravariant -import Data.SOP.Dict (Dict (..)) -import GHC.Stack (HasCallStack) +import Data.Proxy import Ouroboros.Consensus.Ledger.Basics -import Ouroboros.Consensus.Storage.LedgerDB.API -import Ouroboros.Consensus.Storage.LedgerDB.V1.Args +import Ouroboros.Consensus.Storage.LedgerDB.Snapshots import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API -import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.InMemory as InMemory -import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB -import Ouroboros.Consensus.Util.Args -import Ouroboros.Consensus.Util.IOLike import System.FS.API -import System.FS.IO type BackingStoreInitialiser m l = InitFrom (LedgerTables l ValuesMK) -> @@ -58,73 +43,48 @@ type BackingStoreInitialiser m l = -- | Overwrite the 'BackingStore' tables with the snapshot's tables restoreBackingStore :: - ( IOLike m - , HasLedgerTables l - , HasCallStack - , LedgerSupportsV1LedgerDB l - ) => - Tracer m FlavorImplSpecificTrace -> - Complete BackingStoreArgs m -> + Tracer m SomeBackendTrace -> + SomeBackendArgs m l -> SnapshotsFS m -> l EmptyMK -> FsPath -> m (LedgerBackingStore m l) -restoreBackingStore trcr bss fs st loadPath = - newBackingStoreInitialiser trcr bss fs (InitFromCopy st loadPath) +restoreBackingStore trcr (SomeBackendArgs bArgs) fs st loadPath = + newBackingStoreInitialiser trcr bArgs fs (InitFromCopy st loadPath) -- | Create a 'BackingStore' from the given initial tables. newBackingStore :: - ( IOLike m - , HasLedgerTables l - , HasCallStack - , LedgerSupportsV1LedgerDB l - ) => - Tracer m FlavorImplSpecificTrace -> - Complete BackingStoreArgs m -> + Tracer m SomeBackendTrace -> + SomeBackendArgs m l -> SnapshotsFS m -> l EmptyMK -> LedgerTables l ValuesMK -> m (LedgerBackingStore m l) -newBackingStore trcr bss fs st tables = - newBackingStoreInitialiser trcr bss fs (InitFromValues Origin st tables) +newBackingStore trcr (SomeBackendArgs bArgs) fs st tables = + newBackingStoreInitialiser trcr bArgs fs (InitFromValues Origin st tables) -newBackingStoreInitialiser :: - forall m l. - ( IOLike m - , HasLedgerTables l - , HasCallStack - , LedgerSupportsV1LedgerDB l - ) => - Tracer m FlavorImplSpecificTrace -> - Complete BackingStoreArgs m -> - SnapshotsFS m -> - BackingStoreInitialiser m l -newBackingStoreInitialiser trcr bss = - case bss of - LMDBBackingStoreArgs fs limits Dict -> - LMDB.newLMDBBackingStore - (FlavorImplSpecificTraceOnDisk . OnDiskBackingStoreTrace >$< trcr) - limits - (LiveLMDBFS $ SomeHasFS $ ioHasFS $ MountPoint fs) - InMemoryBackingStoreArgs -> - InMemory.newInMemoryBackingStore - (FlavorImplSpecificTraceInMemory . InMemoryBackingStoreTrace >$< trcr) +data SomeBackendArgs m l where + SomeBackendArgs :: Backend m backend l => Args m backend -> SomeBackendArgs m l + +data SomeBackendTrace where + SomeBackendTrace :: Show (Trace m backend) => Trace m backend -> SomeBackendTrace + +instance Show SomeBackendTrace where + show (SomeBackendTrace tr) = show tr -{------------------------------------------------------------------------------- - Tracing --------------------------------------------------------------------------------} +class Backend m backend l where + data Args m backend -data FlavorImplSpecificTrace - = FlavorImplSpecificTraceInMemory FlavorImplSpecificTraceInMemory - | FlavorImplSpecificTraceOnDisk FlavorImplSpecificTraceOnDisk - deriving (Eq, Show) + data Trace m backend -data FlavorImplSpecificTraceInMemory - = InMemoryBackingStoreInitialise - | InMemoryBackingStoreTrace BackingStoreTrace - deriving (Eq, Show) + isRightBackendForSnapshot :: + Proxy l -> + Args m backend -> + SnapshotBackend -> + Bool -data FlavorImplSpecificTraceOnDisk - = OnDiskBackingStoreInitialise LMDB.LMDBLimits - | OnDiskBackingStoreTrace BackingStoreTrace - deriving (Eq, Show) + newBackingStoreInitialiser :: + Tracer m SomeBackendTrace -> + Args m backend -> + SnapshotsFS m -> + BackingStoreInitialiser m l diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/API.hs index 1109be6a3c..02908a7ab7 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/API.hs @@ -2,13 +2,10 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -- | The 'BackingStore' is the component of the LedgerDB V1 implementation that -- stores a key-value map with the 'LedgerTable's at a specific slot on the @@ -276,7 +273,7 @@ data RangeQuery keys = RangeQuery -- the changelog, which is extremely unlikely due to the random access -- pattern of the UTxO set. } - deriving stock (Show, Eq) + deriving (Show, Eq) {------------------------------------------------------------------------------- Statistics @@ -297,7 +294,7 @@ data Statistics = Statistics , numEntries :: !Int -- ^ The total number of key-value pair entries that are stored. } - deriving stock (Show, Eq) + deriving (Show, Eq) {------------------------------------------------------------------------------- Tracing diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/InMemory.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/InMemory.hs index 81231c0243..f20100eae8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/InMemory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/InMemory.hs @@ -2,11 +2,13 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeData #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- | An implementation of a 'BackingStore' using a TVar. This is the @@ -14,6 +16,8 @@ module Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.InMemory ( -- * Constructor newInMemoryBackingStore + , Backend (..) + , Args (InMemArgs) -- * Errors , InMemoryBackingStoreExn (..) @@ -28,6 +32,7 @@ import Control.Monad (join, unless, void, when) import Control.Monad.Class.MonadThrow (catch) import Control.Tracer (Tracer, traceWith) import qualified Data.ByteString.Lazy as BSL +import Data.Functor.Contravariant import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Data.String (fromString) @@ -38,7 +43,7 @@ import Ouroboros.Consensus.Storage.LedgerDB.API import Ouroboros.Consensus.Storage.LedgerDB.Snapshots ( SnapshotBackend (..) ) -import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API +import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore import Ouroboros.Consensus.Util.IOLike ( Exception , IOLike @@ -343,3 +348,26 @@ instance Show InMemoryBackingStoreInitExn where <> show p <> ".\nPre-UTxO-HD and LMDB implementations are incompatible with the In-Memory \ \ implementation. Please delete your ledger database directory." + +type data Mem + +instance + ( IOLike m + , HasLedgerTables l + , CanUpgradeLedgerTables l + , SerializeTablesWithHint l + ) => + Backend m Mem l + where + data Args m Mem = InMemArgs + data Trace m Mem + = InMemoryBackingStoreInitialise + | InMemoryBackingStoreTrace BackingStoreTrace + deriving (Eq, Show) + + isRightBackendForSnapshot _ _ UTxOHDMemSnapshot = True + isRightBackendForSnapshot _ _ _ = False + + newBackingStoreInitialiser trcr InMemArgs = + newInMemoryBackingStore + (SomeBackendTrace . InMemoryBackingStoreTrace >$< trcr) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Snapshots.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Snapshots.hs index 1b543bead8..0e4b658ee3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Snapshots.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Snapshots.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | Snapshots -- @@ -154,7 +155,6 @@ import Ouroboros.Consensus.Storage.LedgerDB.API import Ouroboros.Consensus.Storage.LedgerDB.Args import Ouroboros.Consensus.Storage.LedgerDB.Snapshots import Ouroboros.Consensus.Storage.LedgerDB.TraceEvent -import Ouroboros.Consensus.Storage.LedgerDB.V1.Args import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore as V1 import Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog @@ -283,8 +283,8 @@ loadSnapshot :: , LedgerSupportsV1LedgerDB (LedgerState blk) , LedgerDbSerialiseConstraints blk ) => - Tracer m V1.FlavorImplSpecificTrace -> - Complete BackingStoreArgs m -> + Tracer m V1.SomeBackendTrace -> + SomeBackendArgs m (ExtLedgerState blk) -> CodecConfig blk -> SnapshotsFS m -> ResourceRegistry m -> @@ -293,18 +293,18 @@ loadSnapshot :: (SnapshotFailure blk) m ((DbChangelog' blk, ResourceKey m, LedgerBackingStore m (ExtLedgerState blk)), RealPoint blk) -loadSnapshot tracer bss ccfg fs@(SnapshotsFS fs') reg s = do +loadSnapshot tracer bArgs@(SomeBackendArgs bss) ccfg fs@(SnapshotsFS fs') reg s = do (extLedgerSt, checksumAsRead) <- withExceptT (InitFailureRead . ReadSnapshotFailed) $ readExtLedgerState fs' (decodeDiskExtLedgerState ccfg) decode (snapshotToStatePath s) snapshotMeta <- withExceptT (InitFailureRead . ReadMetadataError (snapshotToMetadataPath s)) $ loadSnapshotMetadata fs' s - case (bss, snapshotBackend snapshotMeta) of - (InMemoryBackingStoreArgs, UTxOHDMemSnapshot) -> pure () - (LMDBBackingStoreArgs _ _ _, UTxOHDLMDBSnapshot) -> pure () - (_, _) -> - throwError $ InitFailureRead $ ReadMetadataError (snapshotToMetadataPath s) MetadataBackendMismatch + Monad.unless + (isRightBackendForSnapshot (Proxy @(ExtLedgerState blk)) bss (snapshotBackend snapshotMeta)) + $ throwError + $ InitFailureRead + $ ReadMetadataError (snapshotToMetadataPath s) MetadataBackendMismatch Monad.when (checksumAsRead /= snapshotChecksum snapshotMeta) $ throwError $ InitFailureRead $ @@ -314,6 +314,10 @@ loadSnapshot tracer bss ccfg fs@(SnapshotsFS fs') reg s = do NotOrigin pt -> do (bsKey, backingStore) <- Trans.lift - (allocate reg (\_ -> restoreBackingStore tracer bss fs extLedgerSt (snapshotToTablesPath s)) bsClose) + ( allocate + reg + (\_ -> restoreBackingStore tracer bArgs fs extLedgerSt (snapshotToTablesPath s)) + bsClose + ) let chlog = empty extLedgerSt pure ((chlog, bsKey, backingStore), pt) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs index 324130c0ea..d0e7bb1c9d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs @@ -1,11 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} @@ -46,16 +43,13 @@ import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsProtocol -import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache import Ouroboros.Consensus.Storage.LedgerDB.API import Ouroboros.Consensus.Storage.LedgerDB.Args import Ouroboros.Consensus.Storage.LedgerDB.Snapshots import Ouroboros.Consensus.Storage.LedgerDB.TraceEvent -import Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 +import Ouroboros.Consensus.Storage.LedgerDB.V2.Backend import Ouroboros.Consensus.Storage.LedgerDB.V2.Forker -import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory -import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq import Ouroboros.Consensus.Util (whenJust) import Ouroboros.Consensus.Util.Args @@ -70,24 +64,30 @@ import Prelude hiding (read) type SnapshotManagerV2 m blk = SnapshotManager m m blk (StateRef m (ExtLedgerState blk)) mkInitDb :: - forall m blk. + forall m blk backend. ( LedgerSupportsProtocol blk - , IOLike m , LedgerDbSerialiseConstraints blk , HasHardForkHistory blk - , LedgerSupportsV2LedgerDB (LedgerState blk) + , Backend m backend blk + , IOLike m ) => Complete LedgerDbArgs m blk -> - HandleEnv m -> ResolveBlock m blk -> SnapshotManagerV2 m blk -> GetVolatileSuffix m blk -> + Resources m backend -> InitDB (LedgerSeq' m blk) m blk -mkInitDb args bss getBlock snapManager getVolatileSuffix = +mkInitDb args getBlock snapManager getVolatileSuffix res = do InitDB { initFromGenesis = emptyF =<< lgrGenesis , initFromSnapshot = - loadSnapshot (configCodec . getExtLedgerCfg . ledgerDbCfg $ lgrConfig) lgrHasFS + runExceptT + . newHandleFromSnapshot + v2Tracer + lgrRegistry + (configCodec . getExtLedgerCfg . ledgerDbCfg $ lgrConfig) + lgrHasFS + res , abortLedgerDbInit = closeLedgerSeq , initReapplyBlock = \a b c -> do (x, y) <- reapplyThenPush lgrRegistry a b c @@ -114,9 +114,7 @@ mkInitDb args bss getBlock snapManager getVolatileSuffix = , ldbQueryBatchSize = lgrQueryBatchSize , ldbOpenHandlesLock = lock , ldbGetVolatileSuffix = getVolatileSuffix - , ldbResourceKeys = case bss of - InMemoryHandleEnv -> Nothing - LSMHandleEnv lsmRes -> Just $ LedgerDBResourceKeys (sessionKey lsmRes) (blockIOKey lsmRes) + , ldbResourceKeys = SomeResources res } h <- LDBHandle <$> newTVarIO (LedgerDBOpen env) pure $ implMkLedgerDb h snapManager @@ -132,29 +130,14 @@ mkInitDb args bss getBlock snapManager getVolatileSuffix = , lgrRegistry } = args - v2Tracer :: Tracer m V2.FlavorImplSpecificTrace - v2Tracer = LedgerDBFlavorImplEvent . FlavorImplSpecificTraceV2 >$< lgrTracer + v2Tracer :: Tracer m LedgerDBV2Trace + v2Tracer = + LedgerDBFlavorImplEvent . FlavorImplSpecificTraceV2 >$< lgrTracer emptyF :: ExtLedgerState blk ValuesMK -> m (LedgerSeq' m blk) - emptyF st = - empty' st $ case bss of - InMemoryHandleEnv -> InMemory.newInMemoryLedgerTablesHandle v2Tracer lgrHasFS - LSMHandleEnv lsmRes -> - \values -> do - table <- - LSM.tableFromValuesMK v2Tracer lgrRegistry (sessionResource lsmRes) (forgetLedgerTables st) values - LSM.newLSMLedgerTablesHandle v2Tracer lgrRegistry table - - loadSnapshot :: - CodecConfig blk -> - SomeHasFS m -> - DiskSnapshot -> - m (Either (SnapshotFailure blk) (LedgerSeq' m blk, RealPoint blk)) - loadSnapshot ccfg fs ds = case bss of - InMemoryHandleEnv -> runExceptT $ InMemory.loadSnapshot v2Tracer lgrRegistry ccfg fs ds - LSMHandleEnv lsmRes -> runExceptT $ LSM.loadSnapshot v2Tracer lgrRegistry ccfg fs (sessionResource lsmRes) ds + emptyF st = empty' st $ newHandleFromValues v2Tracer lgrRegistry res implMkLedgerDb :: forall m l blk. @@ -235,7 +218,8 @@ mkInternals h snapManager = , closeLedgerDB = do let LDBHandle tvar = h getEnv h $ \env -> - whenJust (ldbResourceKeys env) releaseLedgerDBResources + case ldbResourceKeys env of + SomeResources res -> releaseResources (Proxy @blk) res atomically (writeTVar tvar LedgerDBClosed) , getNumLedgerTablesHandles = getEnv h $ \env -> do l <- readTVarIO (ldbSeq env) @@ -387,7 +371,7 @@ implTryTakeSnapshot snapManager env mTime nrBlocks = implTryFlush :: Applicative m => LedgerDBEnv m l blk -> m () implTryFlush _ = pure () -implCloseDB :: IOLike m => LedgerDBHandle m l blk -> m () +implCloseDB :: forall m l blk. IOLike m => LedgerDBHandle m l blk -> m () implCloseDB (LDBHandle varState) = do res <- atomically $ @@ -397,8 +381,8 @@ implCloseDB (LDBHandle varState) = do LedgerDBOpen env -> do writeTVar (ldbForkers env) Map.empty writeTVar varState LedgerDBClosed - pure (ldbResourceKeys env) - whenJust res releaseLedgerDBResources + pure (Just $ ldbResourceKeys env) + whenJust res (\(SomeResources res') -> releaseResources (Proxy @blk) res') {------------------------------------------------------------------------------- The LedgerDBEnv @@ -458,7 +442,7 @@ data LedgerDBEnv m l blk = LedgerDBEnv -- -- * Modify 'ldbSeq' while holding a write lock, and then close the removed -- handles without any locking. See e.g. 'implGarbageCollect'. - , ldbResourceKeys :: !(Maybe (LedgerDBResourceKeys m)) + , ldbResourceKeys :: !(SomeResources m blk) -- ^ Resource keys used in the LSM backend so that the closing function used -- in tests can release such resources. These are the resource keys for the -- LSM session and the resource key for the BlockIO interface. @@ -473,24 +457,10 @@ deriving instance , NoThunks (TxIn l) , NoThunks (TxOut l) , NoThunks (LedgerCfg l) + , NoThunks (SomeResources m blk) ) => NoThunks (LedgerDBEnv m l blk) -data LedgerDBResourceKeys m = LedgerDBResourceKeys - { sessionResourceKey :: ResourceKey m - , blockIOResourceKey :: ResourceKey m - } - deriving Generic - -deriving instance - IOLike m => - NoThunks (LedgerDBResourceKeys m) - -releaseLedgerDBResources :: IOLike m => LedgerDBResourceKeys m -> m () -releaseLedgerDBResources l = do - Monad.void . release . sessionResourceKey $ l - Monad.void . release . blockIOResourceKey $ l - {------------------------------------------------------------------------------- The LedgerDBHandle -------------------------------------------------------------------------------} @@ -512,6 +482,7 @@ deriving instance , NoThunks (TxIn l) , NoThunks (TxOut l) , NoThunks (LedgerCfg l) + , NoThunks (SomeResources m blk) ) => NoThunks (LedgerDBState m l blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Args.hs deleted file mode 100644 index 9e85a59165..0000000000 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Args.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} - -module Ouroboros.Consensus.Storage.LedgerDB.V2.Args - ( FlavorImplSpecificTrace (..) - , HandleArgs (..) - , HandleEnv (..) - , LedgerDbFlavorArgs (..) - , SomeHasFSAndBlockIO (..) - , LSMHandleArgs (..) - , LSMResources (..) - ) where - -import Control.ResourceRegistry -import Data.Typeable -import Database.LSMTree (LSMTreeTrace (..), Salt, Session) -import Ouroboros.Consensus.Util.Args -import System.FS.API -import System.FS.BlockIO.API - -data LedgerDbFlavorArgs f m = V2Args (HandleArgs f m) - --- | The arguments that are needed to create a 'HandleEnv' for the different --- backends. -data HandleArgs f m - = InMemoryHandleArgs - | LSMHandleArgs (LSMHandleArgs f m) - -data LSMHandleArgs f m = LSMArgs - { lsmFilePath :: HKD f FsPath - -- ^ The file path relative to the fast storage directory in which the LSM - -- trees database will be located. See 'NodeDatabasePaths'. - , lsmSalt :: HKD f Salt - , lsmMkFS :: HKD f (ResourceRegistry m -> m (ResourceKey m, SomeHasFSAndBlockIO m)) - } - -data SomeHasFSAndBlockIO m where - SomeHasFSAndBlockIO :: (Eq h, Typeable h) => HasFS m h -> HasBlockIO m h -> SomeHasFSAndBlockIO m - --- | The environment used to create new handles -data HandleEnv m - = InMemoryHandleEnv - | -- | The environment for creating LSM handles. It carries the 'Session' - -- together with its resource key and the resource key of the 'HasBlockIO'. - LSMHandleEnv !(LSMResources m) - -data LSMResources m = LSMResources - { sessionKey :: !(ResourceKey m) - , sessionResource :: !(Session m) - , blockIOKey :: !(ResourceKey m) - } - -data FlavorImplSpecificTrace - = -- | Created a new 'LedgerTablesHandle', potentially by duplicating an - -- existing one. - TraceLedgerTablesHandleCreate - | -- | Closed a 'LedgerTablesHandle'. - TraceLedgerTablesHandleClose - | LSMTrace LSMTreeTrace - deriving Show diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Backend.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Backend.hs new file mode 100644 index 0000000000..7ff562ee48 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Backend.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Common interface for LedgerDB V2 backends +module Ouroboros.Consensus.Storage.LedgerDB.V2.Backend + ( -- * Backend API + Backend (..) + + -- * Existentials + , SomeBackendTrace (..) + , SomeBackendArgs (..) + , SomeResources (..) + + -- * Tracing + , LedgerDBV2Trace (..) + ) where + +import Control.Monad.Except +import Control.ResourceRegistry +import Control.Tracer +import Data.Proxy +import NoThunks.Class +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Storage.LedgerDB.Snapshots +import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq +import System.FS.API + +-- | Operations needed to open and operate a LedgerDB V2 +class NoThunks (Resources m backend) => Backend m backend blk where + -- | The Arguments that will be used initially to create the 'Resources'. + data Args m backend + + -- | The Resources that will be stored in the LedgerDB environment and given + -- to the handle operations. + data Resources m backend + + -- | A trace dependent on the particular backend. + data Trace m backend + + -- | Transform 'Args' into 'Resources', with some context made up of + -- 'LedgerDbArgs'. + mkResources :: + Proxy blk -> + Tracer m LedgerDBV2Trace -> + Args m backend -> + ResourceRegistry m -> + SomeHasFS m -> + m (Resources m backend) + + -- | Release the acquired resources. + releaseResources :: Proxy blk -> Resources m backend -> m () + + -- | Create a new handle from the given values. This will only be called when + -- starting Consensus from Genesis. + newHandleFromValues :: + Tracer m LedgerDBV2Trace -> + ResourceRegistry m -> + Resources m backend -> + ExtLedgerState blk ValuesMK -> + m (LedgerTablesHandle m (ExtLedgerState blk)) + + -- | Create a new handle from a snapshot. + newHandleFromSnapshot :: + Tracer m LedgerDBV2Trace -> + ResourceRegistry m -> + CodecConfig blk -> + SomeHasFS m -> + Resources m backend -> + DiskSnapshot -> + ExceptT (SnapshotFailure blk) m (LedgerSeq' m blk, RealPoint blk) + + -- | Instantiate the 'SnapshotManager' for this backend. + snapshotManager :: + Proxy blk -> + Resources m backend -> + CodecConfig blk -> + Tracer m (TraceSnapshotEvent blk) -> + SomeHasFS m -> + SnapshotManager m m blk (StateRef m (ExtLedgerState blk)) + +{------------------------------------------------------------------------------- + Existentials +-------------------------------------------------------------------------------} + +data SomeBackendTrace where + SomeBackendTrace :: Show (Trace m backend) => Trace m backend -> SomeBackendTrace + +instance Show SomeBackendTrace where + show (SomeBackendTrace tr) = show tr + +data SomeBackendArgs m blk where + SomeBackendArgs :: Backend m backend blk => Args m backend -> SomeBackendArgs m blk + +data SomeResources m blk where + SomeResources :: Backend m backend blk => Resources m backend -> SomeResources m blk + +instance NoThunks (SomeResources m blk) where + wNoThunks ctxt (SomeResources res) = wNoThunks ctxt res + noThunks ctxt (SomeResources res) = noThunks ctxt res + showTypeOf _ = "SomeResources" + +{------------------------------------------------------------------------------- + Tracing +-------------------------------------------------------------------------------} + +data LedgerDBV2Trace + = -- | Created a new 'LedgerTablesHandle', potentially by duplicating an + -- existing one. + TraceLedgerTablesHandleCreate + | -- | Closed a 'LedgerTablesHandle'. + TraceLedgerTablesHandleClose + | BackendTrace SomeBackendTrace + +deriving instance Show SomeBackendTrace => Show LedgerDBV2Trace diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs index 64eb0a0fca..be6ec8a080 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs @@ -1,67 +1,77 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} -{-# LANGUAGE EmptyDataDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeData #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} module Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory - ( -- * LedgerTablesHandle - newInMemoryLedgerTablesHandle - - -- * Snapshots - , loadSnapshot - , snapshotManager - - -- * snapshot-converter - , implTakeSnapshot + ( Backend (..) + , Args (InMemArgs) + , Mem + , YieldArgs (YieldInMemory) + , SinkArgs (SinkInMemory) + , mkInMemoryArgs ) where +import Cardano.Binary as CBOR +import Cardano.Slotting.Slot +import Codec.CBOR.Read import qualified Codec.CBOR.Write as CBOR import Codec.Serialise (decode) +import Control.Monad (replicateM_, unless) import qualified Control.Monad as Monad -import Control.Monad.Trans (lift) +import Control.Monad.Class.MonadST +import Control.Monad.Class.MonadSTM +import Control.Monad.Class.MonadThrow +import Control.Monad.Except +import Control.Monad.State.Strict (execStateT) import Control.Monad.Trans.Except import Control.ResourceRegistry import Control.Tracer +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.Builder.Extra (defaultChunkSize) import Data.Functor.Contravariant ((>$<)) import Data.Functor.Identity import qualified Data.List as List import qualified Data.Map.Strict as Map import Data.Maybe +import Data.MemPack +import Data.Void import GHC.Generics import NoThunks.Class import Ouroboros.Consensus.Block -import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsProtocol import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff +import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Storage.LedgerDB.API import Ouroboros.Consensus.Storage.LedgerDB.Args import Ouroboros.Consensus.Storage.LedgerDB.Snapshots -import Ouroboros.Consensus.Storage.LedgerDB.TraceEvent -import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 +import Ouroboros.Consensus.Storage.LedgerDB.V2.Backend import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq -import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.CBOR (readIncremental) import Ouroboros.Consensus.Util.CRC import Ouroboros.Consensus.Util.Enclose import Ouroboros.Consensus.Util.IOLike +import Streaming +import qualified Streaming as S +import qualified Streaming.Prelude as S import System.FS.API import System.FS.CRC +import qualified System.FilePath as F import Prelude hiding (read) {------------------------------------------------------------------------------- @@ -89,13 +99,13 @@ newInMemoryLedgerTablesHandle :: , CanUpgradeLedgerTables l , SerializeTablesWithHint l ) => - Tracer m V2.FlavorImplSpecificTrace -> + Tracer m LedgerDBV2Trace -> SomeHasFS m -> LedgerTables l ValuesMK -> m (LedgerTablesHandle m l) newInMemoryLedgerTablesHandle tracer someFS@(SomeHasFS hasFS) l = do !tv <- newTVarIO (LedgerTablesHandleOpen l) - traceWith tracer V2.TraceLedgerTablesHandleCreate + traceWith tracer TraceLedgerTablesHandleCreate pure LedgerTablesHandle { close = implClose tracer tv @@ -119,13 +129,13 @@ newInMemoryLedgerTablesHandle tracer someFS@(SomeHasFS hasFS) l = do implClose :: IOLike m => - Tracer m V2.FlavorImplSpecificTrace -> + Tracer m LedgerDBV2Trace -> StrictTVar m (LedgerTablesHandleState l) -> m () implClose tracer tv = do p <- atomically $ swapTVar tv LedgerTablesHandleClosed case p of - LedgerTablesHandleOpen{} -> traceWith tracer V2.TraceLedgerTablesHandleClose + LedgerTablesHandleOpen{} -> traceWith tracer TraceLedgerTablesHandleClose _ -> pure () implDuplicate :: @@ -134,7 +144,7 @@ implDuplicate :: , CanUpgradeLedgerTables l , SerializeTablesWithHint l ) => - Tracer m V2.FlavorImplSpecificTrace -> + Tracer m LedgerDBV2Trace -> StrictTVar m (LedgerTablesHandleState l) -> SomeHasFS m -> m (LedgerTablesHandle m l) @@ -236,19 +246,6 @@ implTablesSize tv = do -------------------------------------------------------------------------------} snapshotManager :: - ( IOLike m - , LedgerDbSerialiseConstraints blk - , LedgerSupportsProtocol blk - ) => - Complete LedgerDbArgs m blk -> - SnapshotManager m m blk (StateRef m (ExtLedgerState blk)) -snapshotManager args = - snapshotManager' - (configCodec . getExtLedgerCfg . ledgerDbCfg $ lgrConfig args) - (LedgerDBSnapshotEvent >$< lgrTracer args) - (lgrHasFS args) - -snapshotManager' :: ( IOLike m , LedgerDbSerialiseConstraints blk , LedgerSupportsProtocol blk @@ -257,7 +254,7 @@ snapshotManager' :: Tracer m (TraceSnapshotEvent blk) -> SomeHasFS m -> SnapshotManager m m blk (StateRef m (ExtLedgerState blk)) -snapshotManager' ccfg tracer fs = +snapshotManager ccfg tracer fs = SnapshotManager { listSnapshots = defaultListSnapshots fs , deleteSnapshot = defaultDeleteSnapshot fs tracer @@ -313,7 +310,7 @@ loadSnapshot :: , IOLike m , LedgerSupportsInMemoryLedgerDB (LedgerState blk) ) => - Tracer m V2.FlavorImplSpecificTrace -> + Tracer m LedgerDBV2Trace -> ResourceRegistry m -> CodecConfig blk -> SomeHasFS m -> @@ -346,3 +343,173 @@ loadSnapshot tracer _rr ccfg fs ds = do InitFailureRead $ ReadSnapshotDataCorruption (,pt) <$> lift (empty extLedgerSt values (newInMemoryLedgerTablesHandle tracer fs)) + +type data Mem + +instance + ( IOLike m + , LedgerDbSerialiseConstraints blk + , LedgerSupportsProtocol blk + , LedgerSupportsInMemoryLedgerDB (LedgerState blk) + ) => + Backend m Mem blk + where + data Args m Mem = InMemArgs + newtype Resources m Mem = Resources (SomeHasFS m) + deriving newtype NoThunks + newtype Trace m Mem = NoTrace Void + deriving newtype Show + + mkResources _ _ _ _ = pure . Resources + releaseResources _ _ = pure () + newHandleFromValues tracer _ (Resources shfs) = + newInMemoryLedgerTablesHandle tracer shfs . ltprj + newHandleFromSnapshot trcr reg ccfg shfs _ ds = + loadSnapshot trcr reg ccfg shfs ds + snapshotManager _ _ = + Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory.snapshotManager + +-- | Create arguments for initializing the LedgerDB using the InMemory backend. +mkInMemoryArgs :: + ( IOLike m + , LedgerDbSerialiseConstraints blk + , LedgerSupportsProtocol blk + , LedgerSupportsInMemoryLedgerDB (LedgerState blk) + ) => + a -> (LedgerDbBackendArgs m blk, a) +mkInMemoryArgs = (,) $ LedgerDbBackendArgsV2 $ SomeBackendArgs InMemArgs + +instance IOLike m => StreamingBackend m Mem l where + data YieldArgs m Mem l + = -- \| Yield an in-memory snapshot + YieldInMemory + -- \| How to make a SomeHasFS for @m@ + (MountPoint -> SomeHasFS m) + -- \| The file path at which the HasFS has to be opened + FilePath + (Decoders l) + + data SinkArgs m Mem l + = SinkInMemory + Int + (TxIn l -> Encoding) + (TxOut l -> Encoding) + (SomeHasFS m) + FilePath + + yield _ (YieldInMemory mkFs fp (Decoders decK decV)) = + yieldInMemoryS mkFs fp decK decV + + sink _ (SinkInMemory chunkSize encK encV shfs fp) = + sinkInMemoryS chunkSize encK encV shfs fp + +{------------------------------------------------------------------------------- + Streaming +-------------------------------------------------------------------------------} + +streamingFile :: + forall m. + MonadThrow m => + SomeHasFS m -> + FsPath -> + ( Stream (Of ByteString) m (Maybe CRC) -> + ExceptT DeserialiseFailure m (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)) + ) -> + ExceptT DeserialiseFailure m (Maybe CRC, Maybe CRC) +streamingFile (SomeHasFS fs') path cont = + ExceptT $ withFile fs' path ReadMode $ \hdl -> + runExceptT $ cont (getBS hdl initCRC) >>= noRemainingBytes + where + getBS h !crc = do + bs <- S.lift $ hGetSome fs' h (fromIntegral defaultChunkSize) + if BS.null bs + then pure (Just crc) + else do + S.yield bs + getBS h $! updateCRC bs crc + + noRemainingBytes s = + lift (S.uncons s) >>= \case + Nothing -> lift $ S.effects s + Just (BS.null -> True, s') -> noRemainingBytes s' + Just _ -> throwError $ DeserialiseFailure 0 "Remaining bytes" + +yieldCborMapS :: + forall m a b. + MonadST m => + (forall s. Decoder s a) -> + (forall s. Decoder s b) -> + Stream (Of ByteString) m (Maybe CRC) -> + Stream (Of (a, b)) (ExceptT DeserialiseFailure m) (Stream (Of ByteString) m (Maybe CRC)) +yieldCborMapS decK decV = execStateT $ do + hoist lift (decodeCbor decodeListLen >> decodeCbor decodeMapLenOrIndef) >>= \case + Nothing -> go + Just n -> replicateM_ n yieldKV + where + yieldKV = do + kv <- hoist lift $ decodeCbor $ (,) <$> decK <*> decV + lift $ S.yield kv + + go = do + doBreak <- hoist lift $ decodeCbor decodeBreakOr + unless doBreak $ yieldKV *> go + + decodeCbor dec = + StateT $ \s -> go' s =<< lift (stToIO (deserialiseIncremental dec)) + where + go' s = \case + Partial k -> + lift (S.next s) >>= \case + Right (bs, s') -> go' s' =<< lift (stToIO (k (Just bs))) + Left r -> go' (pure r) =<< lift (stToIO (k Nothing)) + Codec.CBOR.Read.Done bs _off a -> pure (a, S.yield bs *> s) + Codec.CBOR.Read.Fail _bs _off err -> throwError err + +yieldInMemoryS :: + (MonadThrow m, MonadST m) => + (MountPoint -> SomeHasFS m) -> + FilePath -> + (forall s. Decoder s (TxIn l)) -> + (forall s. Decoder s (TxOut l)) -> + Yield m l +yieldInMemoryS mkFs (F.splitFileName -> (fp, fn)) decK decV _ k = + streamingFile (mkFs $ MountPoint fp) (mkFsPath [fn]) $ \s -> do + k $ yieldCborMapS decK decV s + +sinkInMemoryS :: + forall m l. + MonadThrow m => + Int -> + (TxIn l -> Encoding) -> + (TxOut l -> Encoding) -> + SomeHasFS m -> + FilePath -> + Sink m l +sinkInMemoryS writeChunkSize encK encV (SomeHasFS fs) fp _ s = + ExceptT $ withFile fs (mkFsPath [fp]) (WriteMode MustBeNew) $ \hdl -> do + let bs = toStrictByteString (encodeListLen 1 <> encodeMapLenIndef) + let !crc0 = updateCRC bs initCRC + void $ hPutSome fs hdl bs + e <- runExceptT $ go hdl crc0 writeChunkSize mempty s + case e of + Left err -> pure $ Left err + Right (r, crc1) -> do + let bs1 = toStrictByteString encodeBreak + void $ hPutSome fs hdl bs1 + let !crc2 = updateCRC bs1 crc1 + pure $ Right (fmap (,Just crc2) r) + where + go tb !crc 0 m s' = do + let bs = toStrictByteString $ mconcat [encK k <> encV v | (k, v) <- reverse m] + lift $ void $ hPutSome fs tb bs + let !crc1 = updateCRC bs crc + go tb crc1 writeChunkSize mempty s' + go tb !crc n m s' = do + mbs <- S.uncons s' + case mbs of + Nothing -> do + let bs = toStrictByteString $ mconcat [encK k <> encV v | (k, v) <- reverse m] + lift $ void $ hPutSome fs tb bs + let !crc1 = updateCRC bs crc + (,crc1) <$> S.effects s' + Just (item, s'') -> go tb crc (n - 1) (item : m) s'' diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LedgerSeq.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LedgerSeq.hs index 52f5c9fd33..774c35b5e6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LedgerSeq.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LedgerSeq.hs @@ -211,9 +211,9 @@ empty' :: , HasLedgerTables l ) => l ValuesMK -> - (LedgerTables l ValuesMK -> m (LedgerTablesHandle m l)) -> + (l ValuesMK -> m (LedgerTablesHandle m l)) -> m (LedgerSeq m l) -empty' st = empty (forgetLedgerTables st) (ltprj st) +empty' st = empty (forgetLedgerTables st) st -- | Close all 'LedgerTablesHandle' in this 'LedgerSeq', in particular that on -- the anchor. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/StreamingLedgerTables.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/StreamingLedgerTables.hs deleted file mode 100644 index 805a41d2bc..0000000000 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/StreamingLedgerTables.hs +++ /dev/null @@ -1,372 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Ouroboros.Consensus.Util.StreamingLedgerTables - ( stream - , yield - , sink - , YieldArgs (..) - , SinkArgs (..) - , Decoders (..) - ) where - -import Cardano.Slotting.Slot -import Codec.CBOR.Decoding (Decoder, decodeBreakOr, decodeListLen, decodeMapLenOrIndef) -import Codec.CBOR.Encoding (Encoding, encodeBreak, encodeListLen, encodeMapLenIndef) -import Codec.CBOR.Read -import Codec.CBOR.Write -import Control.Concurrent.Class.MonadMVar -import Control.Monad (replicateM_, unless) -import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadST -import Control.Monad.Class.MonadSTM -import Control.Monad.Class.MonadThrow -import Control.Monad.Except -import Control.Monad.State.Strict -import Control.ResourceRegistry -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.ByteString.Builder.Extra (defaultChunkSize) -import qualified Data.Map.Strict as Map -import Data.MemPack -import Data.Proxy -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Data.Vector as V -import Database.LSMTree -import Ouroboros.Consensus.Ledger.Abstract -import Ouroboros.Consensus.Ledger.Tables.Diff -import Ouroboros.Consensus.Storage.LedgerDB.API -import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API -import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM -import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq -import Ouroboros.Consensus.Util.IndexedMemPack -import Ouroboros.Network.Block -import Streaming -import qualified Streaming as S -import qualified Streaming.Prelude as S -import System.FS.API -import System.FS.CRC -import qualified System.FilePath as F - -data Decoders l - = Decoders - (forall s. Codec.CBOR.Decoding.Decoder s (TxIn l)) - (forall s. Codec.CBOR.Decoding.Decoder s (TxOut l)) - -stream :: - Constraints l m => - l EmptyMK -> - (l EmptyMK -> ResourceRegistry m -> m (YieldArgs l m)) -> - (l EmptyMK -> ResourceRegistry m -> m (SinkArgs l m)) -> - ExceptT DeserialiseFailure m (Maybe CRC, Maybe CRC) -stream st mYieldArgs mSinkArgs = - ExceptT $ - withRegistry $ \reg -> do - yArgs <- mYieldArgs st reg - sArgs <- mSinkArgs st reg - runExceptT $ yield yArgs st $ sink sArgs st - -type Yield l m = - l EmptyMK -> - ( ( Stream (Of (TxIn l, TxOut l)) (ExceptT DeserialiseFailure m) (Stream (Of ByteString) m (Maybe CRC)) -> - ExceptT DeserialiseFailure m (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)) - ) - ) -> - ExceptT DeserialiseFailure m (Maybe CRC, Maybe CRC) - -type Sink l m r = - l EmptyMK -> - Stream (Of (TxIn l, TxOut l)) (ExceptT DeserialiseFailure m) (Stream (Of ByteString) m (Maybe CRC)) -> - ExceptT DeserialiseFailure m (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)) - -instance MonadST m => MonadST (ExceptT e m) where - stToIO = lift . stToIO - -data YieldArgs l m - = -- | Yield an in-memory snapshot - YieldInMemory - -- | How to make a SomeHasFS for @m@ - (MountPoint -> SomeHasFS m) - -- | The file path at which the HasFS has to be opened - FilePath - (Decoders l) - | -- | Yield an LMDB snapshot - YieldLMDB - Int - (LedgerBackingStoreValueHandle m l) - | -- | Yield an LSM snapshot - YieldLSM - Int - (LedgerTablesHandle m l) - -yield :: Constraints l m => YieldArgs l m -> Yield l m -yield = \case - YieldInMemory mkFs fp (Decoders decK decV) -> yieldInMemoryS mkFs fp decK decV - YieldLMDB chunkSize valueHandle -> yieldLmdbS chunkSize valueHandle - YieldLSM chunkSize hdl -> yieldLsmS chunkSize hdl - -type Constraints l m = - ( LedgerSupportsV1LedgerDB l - , LedgerSupportsV2LedgerDB l - , HasLedgerTables l - , GetTip l - , IOLike m - ) - -sink :: - Constraints l m => - SinkArgs l m -> Sink l m r -sink = \case - SinkLMDB chunkSize write copy -> sinkLmdbS chunkSize write copy - SinkLSM chunkSize snapName session -> sinkLsmS chunkSize snapName session - SinkInMemory chunkSize encK encV shfs fp -> sinkInMemoryS chunkSize encK encV shfs fp - -data SinkArgs l m - = SinkInMemory - Int - (TxIn l -> Encoding) - (TxOut l -> Encoding) - (SomeHasFS m) - FilePath - | SinkLSM - -- | Chunk size - Int - -- | Snap name - String - (Session m) - | SinkLMDB - -- | Chunk size - Int - -- | bsWrite - (SlotNo -> (l EmptyMK, l EmptyMK) -> LedgerTables l DiffMK -> m ()) - (l EmptyMK -> m ()) - -{------------------------------------------------------------------------------- - Yielding InMemory --------------------------------------------------------------------------------} - -streamingFile :: - forall m. - MonadThrow m => - SomeHasFS m -> - FsPath -> - ( Stream (Of ByteString) m (Maybe CRC) -> - ExceptT DeserialiseFailure m (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)) - ) -> - ExceptT DeserialiseFailure m (Maybe CRC, Maybe CRC) -streamingFile (SomeHasFS fs') path cont = - ExceptT $ withFile fs' path ReadMode $ \hdl -> - runExceptT $ cont (getBS hdl initCRC) >>= noRemainingBytes - where - getBS h !crc = do - bs <- S.lift $ hGetSome fs' h (fromIntegral defaultChunkSize) - if BS.null bs - then pure (Just crc) - else do - S.yield bs - getBS h $! updateCRC bs crc - - noRemainingBytes s = - lift (S.uncons s) >>= \case - Nothing -> lift $ S.effects s - Just (BS.null -> True, s') -> noRemainingBytes s' - Just _ -> throwError $ DeserialiseFailure 0 "Remaining bytes" - -yieldCborMapS :: - forall m a b. - MonadST m => - (forall s. Decoder s a) -> - (forall s. Decoder s b) -> - Stream (Of ByteString) m (Maybe CRC) -> - Stream (Of (a, b)) (ExceptT DeserialiseFailure m) (Stream (Of ByteString) m (Maybe CRC)) -yieldCborMapS decK decV = execStateT $ do - hoist lift (decodeCbor decodeListLen >> decodeCbor decodeMapLenOrIndef) >>= \case - Nothing -> go - Just n -> replicateM_ n yieldKV - where - yieldKV = do - kv <- hoist lift $ decodeCbor $ (,) <$> decK <*> decV - lift $ S.yield kv - - go = do - doBreak <- hoist lift $ decodeCbor decodeBreakOr - unless doBreak $ yieldKV *> go - - decodeCbor dec = - StateT $ \s -> go' s =<< lift (stToIO (deserialiseIncremental dec)) - where - go' s = \case - Partial k -> - lift (S.next s) >>= \case - Right (bs, s') -> go' s' =<< lift (stToIO (k (Just bs))) - Left r -> go' (pure r) =<< lift (stToIO (k Nothing)) - Done bs _off a -> pure (a, S.yield bs *> s) - Fail _bs _off err -> throwError err - -yieldInMemoryS :: - (MonadThrow m, MonadST m) => - (MountPoint -> SomeHasFS m) -> - FilePath -> - (forall s. Decoder s (TxIn l)) -> - (forall s. Decoder s (TxOut l)) -> - Yield l m -yieldInMemoryS mkFs (F.splitFileName -> (fp, fn)) decK decV _ k = - streamingFile (mkFs $ MountPoint fp) (mkFsPath [fn]) $ \s -> do - k $ yieldCborMapS decK decV s - -{------------------------------------------------------------------------------- - Yielding OnDisk backends --------------------------------------------------------------------------------} - -yieldLmdbS :: - Monad m => - Int -> - LedgerBackingStoreValueHandle m l -> - Yield l m -yieldLmdbS readChunkSize bsvh hint k = do - r <- k (go (RangeQuery Nothing readChunkSize)) - lift $ S.effects r - where - go p = do - (LedgerTables (ValuesMK values), mx) <- lift $ S.lift $ bsvhRangeRead bsvh hint p - case mx of - Nothing -> pure $ pure Nothing - Just x -> do - S.each $ Map.toList values - go (RangeQuery (Just . LedgerTables . KeysMK $ Set.singleton x) readChunkSize) - -yieldLsmS :: - Monad m => - Int -> - LedgerTablesHandle m l -> - Yield l m -yieldLsmS readChunkSize tb hint k = do - r <- k (go (Nothing, readChunkSize)) - lift $ S.effects r - where - go p = do - (LedgerTables (ValuesMK values), mx) <- lift $ S.lift $ readRange tb hint p - if Map.null values - then pure $ pure Nothing - else do - S.each $ Map.toList values - go (mx, readChunkSize) - -{------------------------------------------------------------------------------- - Sink --------------------------------------------------------------------------------} - -sinkLmdbS :: - forall m l r. - (Ord (TxIn l), GetTip l, Monad m) => - Int -> - (SlotNo -> (l EmptyMK, l EmptyMK) -> LedgerTables l DiffMK -> m ()) -> - (l EmptyMK -> m ()) -> - Sink l m r -sinkLmdbS writeChunkSize bs copyTo hint s = do - r <- go writeChunkSize mempty s - lift $ copyTo hint - pure (fmap (,Nothing) r) - where - sl = withOrigin (error "unreachable") id $ pointSlot $ getTip hint - - go 0 m s' = do - lift $ bs sl (hint, hint) (LedgerTables $ DiffMK $ fromMapInserts m) - go writeChunkSize mempty s' - go n m s' = do - mbs <- S.uncons s' - case mbs of - Nothing -> do - lift $ bs sl (hint, hint) (LedgerTables $ DiffMK $ fromMapInserts m) - S.effects s' - Just ((k, v), s'') -> - go (n - 1) (Map.insert k v m) s'' - -sinkLsmS :: - forall l m r. - ( MonadAsync m - , MonadMVar m - , MonadThrow (STM m) - , MonadMask m - , MonadST m - , MonadEvaluate m - , MemPack (TxIn l) - , IndexedMemPack (l EmptyMK) (TxOut l) - ) => - Int -> - String -> - Session m -> - Sink l m r -sinkLsmS writeChunkSize snapName session st s = do - tb :: UTxOTable m <- lift $ newTable session - r <- go tb writeChunkSize mempty s - lift $ - saveSnapshot - (toSnapshotName snapName) - (SnapshotLabel $ T.pack "UTxO table") - tb - lift $ closeTable tb - pure (fmap (,Nothing) r) - where - go tb 0 m s' = do - lift $ - inserts tb $ - V.fromList [(toTxInBytes (Proxy @l) k, toTxOutBytes st v, Nothing) | (k, v) <- m] - go tb writeChunkSize mempty s' - go tb n m s' = do - mbs <- S.uncons s' - case mbs of - Nothing -> do - lift $ - inserts tb $ - V.fromList - [(toTxInBytes (Proxy @l) k, toTxOutBytes st v, Nothing) | (k, v) <- m] - S.effects s' - Just (item, s'') -> go tb (n - 1) (item : m) s'' - -sinkInMemoryS :: - forall m l r. - MonadThrow m => - Int -> - (TxIn l -> Encoding) -> - (TxOut l -> Encoding) -> - SomeHasFS m -> - FilePath -> - Sink l m r -sinkInMemoryS writeChunkSize encK encV (SomeHasFS fs) fp _ s = - ExceptT $ withFile fs (mkFsPath [fp]) (WriteMode MustBeNew) $ \hdl -> do - let bs = toStrictByteString (encodeListLen 1 <> encodeMapLenIndef) - let !crc0 = updateCRC bs initCRC - void $ hPutSome fs hdl bs - e <- runExceptT $ go hdl crc0 writeChunkSize mempty s - case e of - Left err -> pure $ Left err - Right (r, crc1) -> do - let bs1 = toStrictByteString encodeBreak - void $ hPutSome fs hdl bs1 - let !crc2 = updateCRC bs1 crc1 - pure $ Right (fmap (,Just crc2) r) - where - go tb !crc 0 m s' = do - let bs = toStrictByteString $ mconcat [encK k <> encV v | (k, v) <- reverse m] - lift $ void $ hPutSome fs tb bs - let !crc1 = updateCRC bs crc - go tb crc1 writeChunkSize mempty s' - go tb !crc n m s' = do - mbs <- S.uncons s' - case mbs of - Nothing -> do - let bs = toStrictByteString $ mconcat [encK k <> encV v | (k, v) <- reverse m] - lift $ void $ hPutSome fs tb bs - let !crc1 = updateCRC bs crc - (,crc1) <$> S.effects s' - Just (item, s'') -> go tb crc (n - 1) (item : m) s'' diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs index d32ee6522b..8c22333ac4 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs @@ -14,7 +14,6 @@ module Test.Util.ChainDB import Control.Concurrent.Class.MonadSTM.Strict import Control.ResourceRegistry (ResourceRegistry) import Control.Tracer (nullTracer) -import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Config ( TopLevelConfig (topLevelConfigLedger) , configCodec @@ -22,7 +21,7 @@ import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.History.EraParams (eraEpochSize) import Ouroboros.Consensus.Ledger.Basics import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState) -import Ouroboros.Consensus.Protocol.Abstract +import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Storage.ChainDB hiding ( TraceFollowerEvent (..) ) @@ -31,7 +30,8 @@ import Ouroboros.Consensus.Storage.ImmutableDB import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import Ouroboros.Consensus.Storage.LedgerDB import qualified Ouroboros.Consensus.Storage.LedgerDB.Snapshots as LedgerDB -import Ouroboros.Consensus.Storage.LedgerDB.V2.Args +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Backend as V2 +import Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory import Ouroboros.Consensus.Storage.VolatileDB import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util.Args @@ -84,10 +84,9 @@ mkTestChunkInfo = simpleChunkInfo . eraEpochSize . tblcHardForkParams . topLevel -- | Creates a default set of of arguments for ChainDB tests. fromMinimalChainDbArgs :: - ( MonadThrow m - , MonadSTM m - , ConsensusProtocol (BlockProtocol blk) - , PrimMonad m + ( IOLike m + , LedgerSupportsProtocol blk + , LedgerSupportsLedgerDB blk ) => MinimalChainDbArgs m blk -> Complete ChainDbArgs m blk fromMinimalChainDbArgs MinimalChainDbArgs{..} = @@ -131,7 +130,7 @@ fromMinimalChainDbArgs MinimalChainDbArgs{..} = , lgrTracer = nullTracer , lgrRegistry = mcdbRegistry , lgrConfig = configLedgerDb mcdbTopLevelConfig OmitLedgerEvents - , lgrFlavorArgs = LedgerDbFlavorArgsV2 (V2Args InMemoryHandleArgs) + , lgrBackendArgs = LedgerDbBackendArgsV2 $ V2.SomeBackendArgs InMemArgs , lgrQueryBatchSize = DefaultQueryBatchSize , lgrStartSnapshot = Nothing } diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs index efafdc18aa..8ff1e4de74 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs @@ -45,7 +45,8 @@ import Ouroboros.Consensus.Storage.ImmutableDB.Stream hiding import Ouroboros.Consensus.Storage.LedgerDB import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB import Ouroboros.Consensus.Storage.LedgerDB.Snapshots -import Ouroboros.Consensus.Storage.LedgerDB.V1.Args +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Backend as V2 +import Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory import Ouroboros.Consensus.Util.IOLike hiding (newTVarIO) import Ouroboros.Network.Mock.Chain (Chain (..)) import qualified Ouroboros.Network.Mock.Chain as Chain @@ -231,7 +232,7 @@ initLedgerDB s c = do , lgrHasFS = SomeHasFS $ simHasFS fs , lgrGenesis = return testInitExtLedger , lgrTracer = nullTracer - , lgrFlavorArgs = LedgerDbFlavorArgsV1 $ V1Args DefaultFlushFrequency InMemoryBackingStoreArgs + , lgrBackendArgs = LedgerDbBackendArgsV2 $ V2.SomeBackendArgs InMemArgs , lgrConfig = LedgerDB.configLedgerDb (testCfg s) OmitLedgerEvents , lgrQueryBatchSize = DefaultQueryBatchSize , lgrRegistry = reg diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs index b3db17423c..1c45dae1be 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs @@ -16,6 +16,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -61,18 +62,17 @@ import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB import Ouroboros.Consensus.Storage.LedgerDB.Snapshots import Ouroboros.Consensus.Storage.LedgerDB.V1 as V1 import Ouroboros.Consensus.Storage.LedgerDB.V1.Args hiding - ( LedgerDbFlavorArgs + ( LedgerDbBackendArgs ) +import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore as V1 +import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.InMemory as V1.InMemory +import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB import Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots as V1 import Ouroboros.Consensus.Storage.LedgerDB.V2 as V2 -import Ouroboros.Consensus.Storage.LedgerDB.V2.Args hiding - ( LedgerDbFlavorArgs - ) -import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 -import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory +import Ouroboros.Consensus.Storage.LedgerDB.V2.Backend as V2 +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as V2.InMemory import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM import Ouroboros.Consensus.Util hiding (Some) -import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike import qualified Ouroboros.Network.AnchoredSeq as AS import Ouroboros.Network.Protocol.LocalStateQuery.Type @@ -176,7 +176,7 @@ initialEnvironment fsOps getDiskDir mkTestArguments cdb rr = do -------------------------------------------------------------------------------} data TestArguments m = TestArguments - { argFlavorArgs :: !(Complete LedgerDbFlavorArgs m) + { argFlavorArgs :: !(LedgerDbBackendArgs m TestBlock) , argLedgerDbCfg :: !(LedgerDbCfg (ExtLedgerState TestBlock)) } @@ -212,7 +212,8 @@ inMemV1TestArguments :: TestArguments IO inMemV1TestArguments secParam _ _ = TestArguments - { argFlavorArgs = LedgerDbFlavorArgsV1 $ V1Args DisableFlushing InMemoryBackingStoreArgs + { argFlavorArgs = + LedgerDbBackendArgsV1 $ V1Args DisableFlushing $ V1.SomeBackendArgs V1.InMemory.InMemArgs , argLedgerDbCfg = extLedgerDbConfig secParam } @@ -223,7 +224,7 @@ inMemV2TestArguments :: TestArguments IO inMemV2TestArguments secParam _ _ = TestArguments - { argFlavorArgs = LedgerDbFlavorArgsV2 $ V2Args InMemoryHandleArgs + { argFlavorArgs = LedgerDbBackendArgsV2 $ SomeBackendArgs V2.InMemory.InMemArgs , argLedgerDbCfg = extLedgerDbConfig secParam } @@ -235,10 +236,9 @@ lsmTestArguments :: lsmTestArguments secParam salt fp = TestArguments { argFlavorArgs = - LedgerDbFlavorArgsV2 $ - V2Args $ - LSMHandleArgs $ - LSMArgs (mkFsPath $ FilePath.splitDirectories fp) salt (LSM.stdMkBlockIOFS fp) + LedgerDbBackendArgsV2 $ + SomeBackendArgs $ + LSM.LSMArgs (mkFsPath $ FilePath.splitDirectories fp) salt (LSM.stdMkBlockIOFS fp) , argLedgerDbCfg = extLedgerDbConfig secParam } @@ -250,9 +250,10 @@ lmdbTestArguments :: lmdbTestArguments secParam _ fp = TestArguments { argFlavorArgs = - LedgerDbFlavorArgsV1 $ + LedgerDbBackendArgsV1 $ V1Args DisableFlushing $ - LMDBBackingStoreArgs fp (testLMDBLimits 16) Dict.Dict + V1.SomeBackendArgs $ + LMDB.LMDBBackingStoreArgs fp (testLMDBLimits 16) Dict.Dict , argLedgerDbCfg = extLedgerDbConfig secParam } @@ -527,7 +528,7 @@ blockNotFound = -------------------------------------------------------------------------------} openLedgerDB :: - Complete LedgerDbFlavorArgs IO -> + LedgerDbBackendArgs IO TestBlock -> ChainDB IO -> LedgerDbCfg (ExtLedgerState TestBlock) -> SomeHasFS IO -> @@ -549,8 +550,8 @@ openLedgerDB flavArgs env cfg fs rr = do rr DefaultQueryBatchSize Nothing - (ldb, _, od) <- case flavArgs of - LedgerDbFlavorArgsV1 bss -> + (ldb, _, od) <- case lgrBackendArgs args of + LedgerDbBackendArgsV1 bss -> let snapManager = V1.snapshotManager args initDb = V1.mkInitDb @@ -560,34 +561,22 @@ openLedgerDB flavArgs env cfg fs rr = do snapManager (praosGetVolatileSuffix $ ledgerDbCfgSecParam cfg) in openDBInternal args initDb snapManager stream replayGoal - LedgerDbFlavorArgsV2 bss -> do - (snapManager, bss') <- case bss of - V2.V2Args V2.InMemoryHandleArgs -> pure (InMemory.snapshotManager args, V2.InMemoryHandleEnv) - V2.V2Args (V2.LSMHandleArgs (V2.LSMArgs path salt mkFS)) -> do - (rk1, V2.SomeHasFSAndBlockIO fs' blockio) <- mkFS (lgrRegistry args) - session <- - allocate - (lgrRegistry args) - ( \_ -> - LSM.openSession - (LedgerDBFlavorImplEvent . FlavorImplSpecificTraceV2 . V2.LSMTrace >$< lgrTracer args) - fs' - blockio - salt - path - ) - LSM.closeSession - pure - ( LSM.snapshotManager (snd session) args - , V2.LSMHandleEnv (V2.LSMResources (fst session) (snd session) rk1) - ) - let initDb = - V2.mkInitDb - args - bss' - getBlock - snapManager - (praosGetVolatileSuffix $ ledgerDbCfgSecParam cfg) + LedgerDbBackendArgsV2 (V2.SomeBackendArgs bArgs) -> do + res <- + mkResources + (Proxy @TestBlock) + (LedgerDBFlavorImplEvent . FlavorImplSpecificTraceV2 >$< lgrTracer args) + bArgs + (lgrRegistry args) + (lgrHasFS args) + let snapManager = + V2.snapshotManager + (Proxy @TestBlock) + res + (configCodec . getExtLedgerCfg . ledgerDbCfg $ lgrConfig args) + (LedgerDBSnapshotEvent >$< lgrTracer args) + (lgrHasFS args) + let initDb = V2.mkInitDb args getBlock snapManager (praosGetVolatileSuffix $ ledgerDbCfgSecParam cfg) res openDBInternal args initDb snapManager stream replayGoal withRegistry $ \reg -> do vr <- validateFork ldb reg (const $ pure ()) BlockCache.empty 0 (map getHeader volBlocks) @@ -623,6 +612,7 @@ instance RunModel Model (StateT Environment IO) where Environment _ _ chainDb mkArgs fs _ cleanup rr <- get (ldb, testInternals, getNumOpenHandles) <- lift $ do let args = mkArgs secParam salt + -- TODO after a drop and restore we restart the db but the session has been closed below where I wrote blahblahblah openLedgerDB (argFlavorArgs args) chainDb (argLedgerDbCfg args) fs rr put (Environment ldb testInternals chainDb mkArgs fs getNumOpenHandles cleanup rr) pure $ pure () @@ -659,6 +649,7 @@ instance RunModel Model (StateT Environment IO) where Environment _ testInternals chainDb _ _ _ _ _ <- get lift $ do atomically $ modifyTVar (dbChain chainDb) (drop (fromIntegral n)) + -- blahblahblah closeLedgerDB testInternals perform state (Init secParam salt) lk perform _ OpenAndCloseForker _ = do diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/BackingStore.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/BackingStore.hs index 5d83cd9243..7772d34d46 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/BackingStore.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/BackingStore.hs @@ -36,11 +36,9 @@ import Data.Typeable import Ouroboros.Consensus.Ledger.Tables import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff import Ouroboros.Consensus.Ledger.Tables.Utils -import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as BS import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore as BS import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.InMemory as InMemory import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB -import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike hiding ( MonadMask (..) , newMVar @@ -80,19 +78,19 @@ tests = [ adjustOption (scaleQuickCheckTests 10) $ testProperty "InMemory IO SimHasFS" $ testWithIO $ - setupBSEnv BS.InMemoryBackingStoreArgs setupSimHasFS (pure ()) + setupBSEnv InMemory.InMemArgs setupSimHasFS (pure ()) , adjustOption (scaleQuickCheckTests 10) $ testProperty "InMemory IO IOHasFS" $ testWithIO $ do (fp, cleanup) <- setupTempDir - setupBSEnv BS.InMemoryBackingStoreArgs (setupIOHasFS fp) cleanup + setupBSEnv InMemory.InMemArgs (setupIOHasFS fp) cleanup , adjustOption (scaleQuickCheckTests 2) $ testProperty "LMDB IO IOHasFS" $ testWithIO $ do (fp, cleanup) <- setupTempDir lmdbTmpDir <- (FilePath. "BS_LMDB") <$> Dir.getTemporaryDirectory setupBSEnv - (BS.LMDBBackingStoreArgs lmdbTmpDir (testLMDBLimits maxOpenValueHandles) Dict.Dict) + (LMDB.LMDBBackingStoreArgs lmdbTmpDir (testLMDBLimits maxOpenValueHandles) Dict.Dict) (setupIOHasFS fp) (cleanup >> Dir.removeDirectoryRecursive lmdbTmpDir) ] @@ -142,8 +140,9 @@ setupTempDir = do pure (qsmTmpDir, liftIO $ Dir.removeDirectoryRecursive qsmTmpDir) setupBSEnv :: + BS.Backend m backend (OTLedgerState (QC.Fixed Word) (QC.Fixed Word)) => IOLike m => - Complete BS.BackingStoreArgs m -> + BS.Args m backend -> m (SomeHasFS m) -> m () -> m (BSEnv m K K' V D)