Extract backends into separate sublibraries

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"

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))

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

ouroboros-consensus-cardano/changelog.d/20251010_121135_javier.sagredo_extract_2.md

@@ -0,0 +1,3 @@
+<!--
+EMPTY as all changes belong to db-analyser and snapshot-converter
+-->

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,