WIP

Author: jasagredo

ouroboros-consensus-cardano/app/snapshot-converter.hs

@@ -311,23 +311,23 @@ main = withStdTerminalHandles $ do
   run conf args = do
     ccfg <- configCodec . pInfoConfig <$> mkProtocolInfo args
     let
-      getState :: SomeHasFS IO -> FsPath -> IO (ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
+      getState :: SomeHasFS IO -> FsPath -> IO (LedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
       getState fs path = do
         either
           (throwIO . SnapshotError . InitFailureRead @(CardanoBlock StandardCrypto) . ReadSnapshotFailed)
-          pure
+          (pure . first ledgerState)
           =<< runExceptT (readExtLedgerState fs (decodeDiskExtLedgerState ccfg) decode path)
 
     (st, f) <- case from conf of
       Mem fp@(pathToDiskSnapshot -> Just (fs, path, _)) -> do
-        -- (st, _) <- getState fs path
-        pure (lstate, fromInMemory fp)
+        (st, _) <- getState fs path
+        pure (st, fromInMemory fp)
       LMDB fp@(pathToDiskSnapshot -> Just (fs, path, _)) -> do
-        -- (st, _) <- getState (Debug.trace (show fp) fs) (Debug.traceShowId path </> mkFsPath ["state"])
-        pure (lstate, fromLMDB (fp <> "/tables"))
-      LSM fp@(pathToDiskSnapshot -> Just (fs, path, _)) fp2 -> do
-        -- (st, _) <- getState fs path
-        pure (lstate, fromLSM fp2)
+        (st, _) <- getState (Debug.trace (show fp) fs) (Debug.traceShowId path </> mkFsPath ["state"])
+        pure (st, fromLMDB (fp <> "/tables"))
+      LSM fp@(pathToDiskSnapshot -> Just (fs, path, ds)) fp2 -> do
+        (st, _) <- getState fs (Debug.traceShowId path </> mkFsPath ["state"])
+        pure (st, fromLSM fp2 (dsSuffix ds))
     let t = case to conf of
           Mem fp@(pathToDiskSnapshot -> Just (fs, path, _)) ->
             toInMemory fp

ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/StreamingLedgerTables.hs

@@ -29,6 +29,7 @@ import Cardano.Slotting.Time
 import qualified Codec.CBOR.Encoding
 import Control.ResourceRegistry
 import Control.Tracer (nullTracer)
+import qualified Data.Foldable as F
 import Data.Proxy
 import Data.SOP.BasicFunctors
 import Data.SOP.Functors
@@ -143,26 +144,30 @@ limits =
 
 fromLSM ::
   FilePath ->
+  Maybe String ->
   L EmptyMK ->
   ResourceRegistry IO ->
   IO (YieldArgs L IO)
-fromLSM fp hint reg = do
+fromLSM fp mSuffix hint reg = do
   (_, SomeHasFSAndBlockIO hasFS blockIO) <- stdMkBlockIOFS fp reg
   salt <- fst . genWord64 <$> newStdGen
   (_, session) <-
     allocate reg (\_ -> openSession nullTracer hasFS blockIO salt (mkFsPath ["lsm"])) closeSession
   tb <-
     allocate
       reg
-      ( \_ ->
+      ( \_ -> do
+          F.traverse_ print =<< listSnapshots session
           openTableFromSnapshot
             session
             ( toSnapshotName $
-                show $
-                  unSlotNo $
-                    withOrigin (error "impossible") id $
-                      pointSlot $
-                        Ouroboros.Consensus.Ledger.Abstract.getTip hint
+                maybe id (\su sl -> sl <> "_" <> su) mSuffix $
+                  ( show $
+                      unSlotNo $
+                        withOrigin (error "impossible") id $
+                          pointSlot $
+                            Ouroboros.Consensus.Ledger.Abstract.getTip hint
+                  )
             )
             (SnapshotLabel $ T.pack "UTxO table")
       )

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs

@@ -14,6 +14,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 -- | Implementation of the 'LedgerTablesHandle' interface with LSM trees.
@@ -47,6 +48,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.V2.LSM
   , LSM.SnapshotLabel (LSM.SnapshotLabel)
   , LSM.openTableFromSnapshot
   , LSM.closeTable
+  , LSM.listSnapshots
   ) where
 
 import Cardano.Binary as CBOR
@@ -72,6 +74,7 @@ import qualified Data.Vector.Primitive as VP
 import Data.Void
 import Database.LSMTree (Session, Table)
 import qualified Database.LSMTree as LSM
+import qualified Debug.Trace as Debug
 import NoThunks.Class
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Config
@@ -119,16 +122,16 @@ toTxOutBytes st txout =
    in TxOutBytes $ LSM.RawBytes (VP.Vector 0 (PBA.sizeofByteArray barr) barr)
 
 fromTxOutBytes :: IndexedMemPack (l EmptyMK) (TxOut l) => l EmptyMK -> TxOutBytes -> TxOut l
-fromTxOutBytes st (TxOutBytes (LSM.RawBytes (VP.Vector _ _ barr))) =
-  case indexedUnpack st barr of
+fromTxOutBytes st (TxOutBytes (LSM.RawBytes (VP.force -> (VP.Vector off _ barr)))) =
+  case indexedUnpackLeftOver' st barr of
     Left err ->
       error $
         unlines
           [ "There was an error deserializing a TxOut from the LSM backend."
           , "This will likely result in a restart-crash loop."
           , "The error: " <> show err
           ]
-    Right v -> v
+    Right (v, _) -> v
 
 instance LSM.SerialiseValue TxOutBytes where
   serialiseValue = unTxOutBytes
@@ -148,16 +151,16 @@ toTxInBytes _ txin =
    in TxInBytes $ LSM.RawBytes (VP.Vector 0 (PBA.sizeofByteArray barr) barr)
 
 fromTxInBytes :: MemPack (TxIn l) => Proxy l -> TxInBytes -> TxIn l
-fromTxInBytes _ (TxInBytes (LSM.RawBytes (VP.Vector _ _ barr))) =
-  case unpack barr of
+fromTxInBytes _ (TxInBytes (LSM.RawBytes (VP.force -> (VP.Vector off _ barr)))) =
+  case unpackLeftOver' barr of
     Left err ->
       error $
         unlines
           [ "There was an error deserializing a TxIn from the LSM backend."
           , "This will likely result in a restart-crash loop."
           , "The error: " <> show err
           ]
-    Right v -> v
+    Right (v, _) -> v
 
 instance LSM.SerialiseKey TxInBytes where
   serialiseKey = unTxInBytes

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IndexedMemPack.hs

@@ -17,6 +17,8 @@ module Ouroboros.Consensus.Util.IndexedMemPack
   , indexedPackByteArray
   , indexedUnpackError
   , indexedUnpack
+  , indexedUnpackLeftOver'
+  , unpackLeftOver'
   ) where
 
 import qualified Control.Monad as Monad
@@ -87,6 +89,18 @@ indexedUnpackLeftOver idx b = do
   pure res
 {-# INLINEABLE indexedUnpackLeftOver #-}
 
+indexedUnpackLeftOver' ::
+  forall idx a b.
+  (IndexedMemPack idx a, Buffer b, HasCallStack) => idx -> b -> Either SomeError (a, Int)
+indexedUnpackLeftOver' idx = first fromMultipleErrors . runFailAgg . indexedUnpackLeftOver idx
+{-# INLINEABLE indexedUnpackLeftOver' #-}
+
+unpackLeftOver' ::
+  forall a b.
+  (MemPack a, Buffer b, HasCallStack) => b -> Either SomeError (a, Int)
+unpackLeftOver' = first fromMultipleErrors . runFailAgg . unpackLeftOver
+{-# INLINEABLE unpackLeftOver' #-}
+
 errorLeftOver :: HasCallStack => String -> Int -> Int -> a
 errorLeftOver name consumedBytes len =
   error $