Non-native snapshots hook

cabal.project

@@ -82,12 +82,12 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/IntersectMBO/ouroboros-consensus
-  tag: 513d27d99b2486bf16d44a9f845ddb358244673f
-  --sha256: 0brlyrvhqxcpya6frx1w5bwbpz5bjjsvxm26951vf2lxah8rx8hp
+  tag: d8ed0283f073ebd5e4664df2740df0d60178ca40
+  --sha256: 1n7xbw0mwk46f6y1knjvj8x32281zrc2m7022inqwk3diswdygvr
   subdir:
     ouroboros-consensus
-    ouroboros-consensus-cardano
     ouroboros-consensus-diffusion
+    ouroboros-consensus-cardano
 
 source-repository-package
   type: git

cardano-node/app/cardano-node.hs

@@ -8,8 +8,9 @@ import           Cardano.Git.Rev (gitRev)
 import           Cardano.Node.Configuration.POM (PartialNodeConfiguration(..))
 import           Cardano.Node.Handlers.TopLevel
 import           Cardano.Node.Parsers (nodeCLIParser, parserHelpHeader, parserHelpOptions,
-                   renderHelpDoc)
+                   renderHelpDoc, parseSnapshotsCmd)
 import           Cardano.Node.Run (runNode)
+import           Cardano.Snapshots.Run (canonicalizeSnapshots, NodeDatabasePaths)
 import           Cardano.Node.Tracing.Documentation (TraceDocumentationCmd (..),
                    parseTraceDocumentationCmd, runTraceDocumentationCmd)
 
@@ -37,6 +38,7 @@ main = do
         warnIfSet args pncMaybeMempoolCapacityOverride "mempool-capacity-override" "MempoolCapacityBytesOverride"
         runNode args
       TraceDocumentation tdc -> runTraceDocumentationCmd tdc
+      CanonicalizeSnapshotsCmd cfg db -> canonicalizeSnapshots cfg db
       VersionCmd  -> runVersionCommand
 
     where
@@ -54,29 +56,32 @@ main = do
 
       opts :: Opt.ParserInfo Command
       opts =
-        Opt.info (fmap RunCmd nodeCLIParser
+        let pp = fmap RunCmd nodeCLIParser
                   <|> fmap TraceDocumentation parseTraceDocumentationCmd
                   <|> parseVersionCmd
-                  <**> helperBrief "help" "Show this help text" nodeCliHelpMain)
+                  <|> fmap (uncurry CanonicalizeSnapshotsCmd) parseSnapshotsCmd
+        in Opt.info (pp
+                  <**> helperBrief "help" "Show this help text" (nodeCliHelpMain pp))
 
           ( Opt.fullDesc <>
-            Opt.progDesc "Start node of the Cardano blockchain."
+            Opt.progDesc "The Cardano blockchain node"
           )
 
       helperBrief :: String -> String -> String -> Parser (a -> a)
       helperBrief l d helpText = Opt.abortOption (Opt.InfoMsg helpText) $ mconcat
         [ Opt.long l
         , Opt.help d ]
 
-      nodeCliHelpMain :: String
-      nodeCliHelpMain = renderHelpDoc 80 $
-        parserHelpHeader "cardano-node" nodeCLIParser
+      nodeCliHelpMain :: Parser a -> String
+      nodeCliHelpMain pp = renderHelpDoc 80 $
+        parserHelpHeader "cardano-node" pp
         <$$> ""
         <$$> parserHelpOptions nodeCLIParser
 
 
 data Command = RunCmd PartialNodeConfiguration
              | TraceDocumentation TraceDocumentationCmd
+             | CanonicalizeSnapshotsCmd (Maybe FilePath) (Maybe NodeDatabasePaths)
              | VersionCmd
 
 -- Yes! A --version flag or version command. Either guess is right!

cardano-node/cardano-node.cabal

@@ -132,6 +132,7 @@ library
                         Cardano.Tracing.Shutdown
                         Cardano.Tracing.Startup
                         Cardano.Tracing.Tracers
+                        Cardano.Snapshots.Run
 
   other-modules:        Paths_cardano_node
   autogen-modules:      Paths_cardano_node
@@ -189,7 +190,7 @@ library
                       , nothunks
                       , optparse-applicative-fork >= 0.18.1
                       , ouroboros-consensus:{ouroboros-consensus, ouroboros-consensus-lmdb, ouroboros-consensus-lsm} ^>= 0.28
-                      , ouroboros-consensus-cardano ^>= 0.26
+                      , ouroboros-consensus-cardano:{ouroboros-consensus-cardano, snapshot-conversion} ^>= 0.26
                       , ouroboros-consensus-diffusion ^>= 0.24
                       , ouroboros-consensus-protocol
                       , ouroboros-network-api ^>= 0.16
@@ -198,6 +199,7 @@ library
                       , ouroboros-network-protocols ^>= 0.15
                       , prettyprinter
                       , prettyprinter-ansi-terminal
+                      , process
                       , psqueues
                       , random
                       , resource-registry

cardano-node/src/Cardano/Node/Configuration/POM.hs

@@ -174,6 +174,8 @@ data NodeConfiguration
        , ncGenesisConfig :: GenesisConfig
 
        , ncResponderCoreAffinityPolicy :: ResponderCoreAffinityPolicy
+
+       , ncCanonicalSnapshotOutputPath :: Maybe FilePath
        } deriving (Eq, Show)
 
 -- | We expose the `Ouroboros.Network.Mux.ForkPolicy` as a `NodeConfiguration` field.
@@ -269,6 +271,8 @@ data PartialNodeConfiguration
        , pncGenesisConfigFlags :: !(Last GenesisConfigFlags)
 
        , pncResponderCoreAffinityPolicy :: !(Last ResponderCoreAffinityPolicy)
+
+       , pncCanonicalSnapshotOutputPath :: !(Last FilePath)
        } deriving (Eq, Generic, Show)
 
 instance AdjustFilePaths PartialNodeConfiguration where
@@ -381,6 +385,9 @@ instance FromJSON PartialNodeConfiguration where
         <$> v .:? "ResponderCoreAffinityPolicy"
         <*> v .:? "ForkPolicy" -- deprecated
 
+      pncCanonicalSnapshotOutputPath <-
+         Last <$> v .:? "CanonicalSnapshotsOutputPath"
+
       pure PartialNodeConfiguration {
              pncProtocolConfig
            , pncSocketConfig = Last . Just $ SocketConfig mempty mempty mempty pncSocketPath
@@ -425,6 +432,7 @@ instance FromJSON PartialNodeConfiguration where
            , pncPeerSharing
            , pncGenesisConfigFlags
            , pncResponderCoreAffinityPolicy
+           , pncCanonicalSnapshotOutputPath
            }
     where
       parseMempoolCapacityBytesOverride v = parseNoOverride <|> parseOverride
@@ -687,6 +695,7 @@ defaultPartialNodeConfiguration =
     , pncGenesisConfigFlags = Last (Just defaultGenesisConfigFlags)
       -- https://ouroboros-consensus.cardano.intersectmbo.org/haddocks/ouroboros-consensus-diffusion/Ouroboros-Consensus-Node-Genesis.html#v:defaultGenesisConfigFlags
     , pncResponderCoreAffinityPolicy = Last $ Just NoResponderCoreAffinity
+    , pncCanonicalSnapshotOutputPath = mempty
     }
 
 lastOption :: Parser a -> Parser (Last a)
@@ -872,6 +881,7 @@ makeNodeConfiguration pnc = do
              , ncConsensusMode
              , ncGenesisConfig
              , ncResponderCoreAffinityPolicy
+             , ncCanonicalSnapshotOutputPath = getLast $ pncCanonicalSnapshotOutputPath pnc
              }
 
 ncProtocol :: NodeConfiguration -> Protocol

cardano-node/src/Cardano/Node/Parsers.hs

@@ -11,6 +11,7 @@ module Cardano.Node.Parsers
   , parserHelpOptions
   , renderHelpDoc
   , parseHostPort
+  , parseSnapshotsCmd
   ) where
 
 import           Cardano.Logging.Types
@@ -140,6 +141,7 @@ nodeRunParser = do
            , pncPeerSharing = mempty
            , pncGenesisConfigFlags = mempty
            , pncResponderCoreAffinityPolicy = mempty
+           , pncCanonicalSnapshotOutputPath = mempty
            }
 
 parseSocketPath :: Text -> Parser SocketPath
@@ -434,3 +436,15 @@ parserHelpOptions = fromMaybe mempty . OptI.unChunk . OptI.fullDesc (Opt.prefs m
 renderHelpDoc :: Int -> OptI.Doc -> String
 renderHelpDoc cols =
   (`OptI.renderShowS` "") . OptI.layoutPretty (OptI.LayoutOptions (OptI.AvailablePerLine cols 1.0))
+
+parseSnapshotsCmd :: Parser (Maybe FilePath, Maybe NodeDatabasePaths)
+parseSnapshotsCmd = subparser
+                (  commandGroup "Canonicalize snapshots"
+                <> metavar "run"
+                <> command "canonicalize-snapshots"
+                     (info (((,)
+                             <$> optional parseConfigFile
+                             <*> optional (parseDbPath <|> fmap OnePathForAllDbs parseImmutableDbPath)
+                             ) <**> helper)
+                           (progDesc "Canonicalize all snapshots" ))
+                )

cardano-node/src/Cardano/Node/Tracing/API.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE MonoLocalBinds #-}
 {-# LANGUAGE PackageImports #-}
@@ -37,7 +38,8 @@ import           Prelude
 
 import           Control.DeepSeq (deepseq)
 import           Control.Monad (forM_)
-import           "contra-tracer" Control.Tracer (traceWith)
+import           "contra-tracer" Control.Tracer (traceWith, Tracer)
+import qualified "contra-tracer" Control.Tracer as CT
 import           "trace-dispatcher" Control.Tracer (nullTracer)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe
@@ -48,7 +50,11 @@ import           System.Metrics as EKG
 
 import           Trace.Forward.Forwarding (initForwardingDelayed)
 import           Trace.Forward.Utils.TraceObject (writeToSink)
-
+import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
+import Ouroboros.Consensus.Util.Enclose
+import qualified Ouroboros.Consensus.Storage.LedgerDB.Snapshots as LedgerDB
+import qualified Ouroboros.Consensus.Storage.LedgerDB.TraceEvent as LedgerDB
+import Cardano.Snapshots.Run
 
 initTraceDispatcher ::
   forall blk.
@@ -69,7 +75,16 @@ initTraceDispatcher nc p networkMagic nodeKernel noBlockForging = do
                 (unConfigPath $ ncConfigFile nc)
                 defaultCardanoConfig
 
-  (kickoffForwarder, kickoffPrometheusSimple, tracers) <- mkTracers trConfig
+  let onChainDbEvent = if isJust (ncCanonicalSnapshotOutputPath nc)
+        then CT.Tracer $ \case
+          (ChainDB.TraceLedgerDBEvent
+           (LedgerDB.LedgerDBSnapshotEvent
+            (LedgerDB.TookSnapshot _ _ (FallingEdgeWith _)))
+           ) -> spawnCanonicalizer
+          _ -> pure ()
+        else CT.nullTracer
+
+  (kickoffForwarder, kickoffPrometheusSimple, tracers) <- mkTracers trConfig onChainDbEvent
 
   -- The NodeInfo DataPoint needs to be fully evaluated and stored
   -- before it is queried for the first time by cardano-tracer.
@@ -107,11 +122,12 @@ initTraceDispatcher nc p networkMagic nodeKernel noBlockForging = do
 
   mkTracers
     :: TraceConfig
+    -> Tracer IO (ChainDB.TraceEvent blk)
     -> IO ( IO ()
           , IO (Maybe String)
           , Tracers RemoteAddress LocalAddress blk IO
           )
-  mkTracers trConfig = do
+  mkTracers trConfig onChainDbEvent = do
     ekgStore <- EKG.newStore
     EKG.registerGcMetrics ekgStore
     ekgTrace <- ekgTracer trConfig ekgStore
@@ -144,6 +160,7 @@ initTraceDispatcher nc p networkMagic nodeKernel noBlockForging = do
         nodeKernel
         stdoutTrace
         fwdTracer
+        onChainDbEvent
         (Just ekgTrace)
         dpTracer
         trConfig

cardano-node/src/Cardano/Node/Tracing/Tracers.hs

@@ -79,13 +79,14 @@ mkDispatchTracers
   => NodeKernelData blk
   -> Trace IO FormattedMessage
   -> Trace IO FormattedMessage
+  -> Tracer IO (ChainDB.TraceEvent blk)
   -> Maybe (Trace IO FormattedMessage)
   -> Trace IO DataPoint
   -> TraceConfig
   -> SomeConsensusProtocol
   -> IO (Tracers RemoteAddress LocalAddress blk IO)
 
-mkDispatchTracers nodeKernel trBase trForward mbTrEKG trDataPoint trConfig p = do
+mkDispatchTracers nodeKernel trBase trForward onChainDBEventTracer mbTrEKG trDataPoint trConfig p  = do
 
     configReflection <- emptyConfigReflection
 
@@ -175,6 +176,7 @@ mkDispatchTracers nodeKernel trBase trForward mbTrEKG trDataPoint trConfig p = d
         chainDBTracer = Tracer (traceWith chainDBTr')
                       <> Tracer (traceWith replayBlockTr')
                       <> Tracer (SR.traceNodeStateChainDB p nodeStateDP)
+                      <> onChainDBEventTracer
       , consensusTracers = consensusTr
       , churnModeTracer = Tracer (traceWith churnModeTr)
       , nodeToClientTracers = nodeToClientTr

cardano-node/src/Cardano/Snapshots/Run.hs

@@ -0,0 +1,97 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Cardano.Snapshots.Run (
+    canonicalizeSnapshots,
+    spawnCanonicalizer,
+    NodeDatabasePaths,
+) where
+
+import qualified Cardano.Api.Consensus as Api
+import Cardano.Node.Configuration.LedgerDB
+import Cardano.Node.Configuration.POM
+import Cardano.Node.Parsers (nodeCLIParser)
+import Cardano.Node.Protocol
+import Cardano.Node.Types (ConfigYamlFilePath (..))
+import Control.Exception
+import Control.Monad (forM_, void)
+import Control.Monad.Class.MonadFork
+import Control.Monad.Except
+import Data.Maybe (fromMaybe)
+import Data.Monoid (Last (..))
+import Options.Applicative
+import Ouroboros.Consensus.Cardano.SnapshotConversion
+import Ouroboros.Consensus.Node (NodeDatabasePaths (..), immutableDbPath)
+import System.Directory (doesFileExist, listDirectory)
+import System.Environment
+import System.FilePath ((</>))
+import System.IO (hPutStrLn, stderr)
+import System.Process
+
+spawnCanonicalizer :: IO ()
+spawnCanonicalizer =
+    void $ forkIO $ do
+        putStrLn "SPAWNING"
+        progName <- getExecutablePath
+        putStrLn progName
+        mPnc <- execParserPure defaultPrefs (info nodeCLIParser mempty) <$> getArgs
+        case mPnc of
+            Success pnc -> do
+                let cfg = case getLast $ pncConfigFile pnc of
+                           Nothing -> []
+                           Just (ConfigYamlFilePath cfgFile) -> ["--config", cfgFile]
+                    db = case getLast $ pncDatabaseFile pnc of
+                           Nothing -> []
+                           Just (OnePathForAllDbs p) -> ["--database-path", p]
+                           Just (MultipleDbPaths imm _) -> ["--database-path", imm]
+                (_, out, err) <-
+                    readProcessWithExitCode progName ("canonicalize-snapshots" : cfg ++ db) ""
+                putStrLn out
+                hPutStrLn stderr err
+            _ -> pure ()
+
+canonicalizeSnapshots :: Maybe FilePath -> Maybe NodeDatabasePaths -> IO ()
+canonicalizeSnapshots cfg (Last -> db) = do
+    configYamlPc <- parseNodeConfigurationFP $ Just $ ConfigYamlFilePath $ fromMaybe "configuration/cardano/mainnet-config.json" cfg
+
+    let cfgFromFile = defaultPartialNodeConfiguration <> configYamlPc
+
+        mOut = getLast (pncCanonicalSnapshotOutputPath cfgFromFile)
+
+        mOtherConfigs = do
+            a <- getLast (pncDatabaseFile cfgFromFile <> db)
+            b <- getLast (pncLedgerDbConfig cfgFromFile)
+            c <- getLast (pncProtocolConfig cfgFromFile)
+            d <- getLast (pncProtocolFiles cfgFromFile)
+            pure (a, b, c, d)
+
+    case (mOut, mOtherConfigs) of
+        (Nothing, _) -> pure ()
+        (_, Nothing) -> error "Impossible, some arguments were missing yet there should be at least a default value for those"
+        (Just out, Just (immutableDbPath -> dbPath, LedgerDbConfiguration _ _ _ selector _, pInfo, cfgFiles)) -> do
+            snaps <- listDirectory (dbPath </> "ledger")
+            someConsensusProto <-
+                runThrowExceptT $
+                    mkConsensusProtocol
+                        pInfo
+                        (Just cfgFiles)
+            case someConsensusProto of
+                SomeConsensusProtocol Api.CardanoBlockType pInfoArgs -> do
+                    let inFmt = case selector of
+                            V1LMDB{} -> LMDB
+                            V2InMemory{} -> Mem
+                            V2LSM Nothing -> flip LSM (dbPath </> "lsm")
+                            V2LSM (Just lsmDb) -> flip LSM (dbPath </> lsmDb)
+                    forM_ snaps $ \snap -> do
+                        exists <- doesFileExist (out </> snap </> "meta")
+                        if exists
+                            then putStrLn $ "Snapshot at " <> dbPath </> "ledger" </> snap <> " already converted"
+                            else do
+                                putStrLn $ "Converting snapshot at " <> dbPath </> "ledger" </> snap
+                                runThrowExceptT $ convertSnapshot False (fst $ Api.protocolInfo @IO pInfoArgs) (inFmt (dbPath </> "ledger" </> snap)) (Mem $ out </> snap)
+                    putStrLn "Done"
+                _ -> pure ()
+
+runThrowExceptT :: (Exception e) => ExceptT e IO a -> IO a
+runThrowExceptT act = runExceptT act >>= either throwIO pure