{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

module Main (main) where

import Cardano.Crypto.Init (cryptoInit)
import Cardano.Tools.DBAnalyser.HasAnalysis (mkProtocolInfo)
import Codec.Serialise
import qualified Control.Monad as Monad
import Control.Monad.Except
import qualified Control.Monad.Trans as Trans (lift)
import Control.ResourceRegistry (ResourceRegistry)
import qualified Control.ResourceRegistry as RR
import Control.Tracer (nullTracer)
import DBAnalyser.Parsers
import Data.Bifunctor
import qualified Data.ByteString.Builder as BS
import qualified Data.SOP.Dict as Dict
import Main.Utf8
import Options.Applicative
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.Basics
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Ledger.SupportsProtocol
import Ouroboros.Consensus.Ledger.Tables.Utils
import Ouroboros.Consensus.Node.ProtocolInfo
import Ouroboros.Consensus.Storage.LedgerDB
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as V1
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore as V1
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as V1
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog as V1
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Lock as V1
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots as V1
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as V2
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq as V2
import Ouroboros.Consensus.Util.CRC
import Ouroboros.Consensus.Util.IOLike
import System.FS.API
import System.FS.API.Lazy
import System.FS.CRC
import System.FS.IO
import System.FilePath (splitFileName)
import System.IO.Temp

data Format
  = Legacy
  | Mem
  | LMDB
  deriving (Int -> Format -> ShowS
[Format] -> ShowS
Format -> FilePath
(Int -> Format -> ShowS)
-> (Format -> FilePath) -> ([Format] -> ShowS) -> Show Format
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Format -> ShowS
showsPrec :: Int -> Format -> ShowS
$cshow :: Format -> FilePath
show :: Format -> FilePath
$cshowList :: [Format] -> ShowS
showList :: [Format] -> ShowS
Show, ReadPrec [Format]
ReadPrec Format
Int -> ReadS Format
ReadS [Format]
(Int -> ReadS Format)
-> ReadS [Format]
-> ReadPrec Format
-> ReadPrec [Format]
-> Read Format
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Format
readsPrec :: Int -> ReadS Format
$creadList :: ReadS [Format]
readList :: ReadS [Format]
$creadPrec :: ReadPrec Format
readPrec :: ReadPrec Format
$creadListPrec :: ReadPrec [Format]
readListPrec :: ReadPrec [Format]
Read)

data Config = Config
  { Config -> Format
from :: Format
  -- ^ Which format the input snapshot is in
  , Config -> FilePath
inpath :: FilePath
  -- ^ Path to the input snapshot
  , Config -> Format
to :: Format
  -- ^ Which format the output snapshot must be in
  , Config -> FilePath
outpath :: FilePath
  -- ^ Path to the output snapshot
  }

getCommandLineConfig :: IO (Config, BlockType)
getCommandLineConfig :: IO (Config, BlockType)
getCommandLineConfig =
  ParserInfo (Config, BlockType) -> IO (Config, BlockType)
forall a. ParserInfo a -> IO a
execParser (ParserInfo (Config, BlockType) -> IO (Config, BlockType))
-> ParserInfo (Config, BlockType) -> IO (Config, BlockType)
forall a b. (a -> b) -> a -> b
$
    Parser (Config, BlockType)
-> InfoMod (Config, BlockType) -> ParserInfo (Config, BlockType)
forall a. Parser a -> InfoMod a -> ParserInfo a
info
      ((,) (Config -> BlockType -> (Config, BlockType))
-> Parser Config -> Parser (BlockType -> (Config, BlockType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Config
parseConfig Parser (BlockType -> (Config, BlockType))
-> Parser BlockType -> Parser (Config, BlockType)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser BlockType
blockTypeParser Parser (Config, BlockType)
-> Parser ((Config, BlockType) -> (Config, BlockType))
-> Parser (Config, BlockType)
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser ((Config, BlockType) -> (Config, BlockType))
forall a. Parser (a -> a)
helper)
      (InfoMod (Config, BlockType)
forall a. InfoMod a
fullDesc InfoMod (Config, BlockType)
-> InfoMod (Config, BlockType) -> InfoMod (Config, BlockType)
forall a. Semigroup a => a -> a -> a
<> FilePath -> InfoMod (Config, BlockType)
forall a. FilePath -> InfoMod a
progDesc FilePath
"Utility for converting snapshots to and from UTxO-HD")

parseConfig :: Parser Config
parseConfig :: Parser Config
parseConfig =
  Format -> FilePath -> Format -> FilePath -> Config
Config
    (Format -> FilePath -> Format -> FilePath -> Config)
-> Parser Format
-> Parser (FilePath -> Format -> FilePath -> Config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM Format -> Mod ArgumentFields Format -> Parser Format
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument
      ReadM Format
forall a. Read a => ReadM a
auto
      ( [Mod ArgumentFields Format] -> Mod ArgumentFields Format
forall a. Monoid a => [a] -> a
mconcat
          [ FilePath -> Mod ArgumentFields Format
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"From format (Legacy, Mem or LMDB)"
          , FilePath -> Mod ArgumentFields Format
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"FORMAT-IN"
          ]
      )
    Parser (FilePath -> Format -> FilePath -> Config)
-> Parser FilePath -> Parser (Format -> FilePath -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod ArgumentFields FilePath -> Parser FilePath
forall s. IsString s => Mod ArgumentFields s -> Parser s
strArgument
      ( [Mod ArgumentFields FilePath] -> Mod ArgumentFields FilePath
forall a. Monoid a => [a] -> a
mconcat
          [ FilePath -> Mod ArgumentFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Input dir/file. Use relative paths like ./100007913"
          , FilePath -> Mod ArgumentFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"PATH-IN"
          ]
      )
    Parser (Format -> FilePath -> Config)
-> Parser Format -> Parser (FilePath -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadM Format -> Mod ArgumentFields Format -> Parser Format
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument
      ReadM Format
forall a. Read a => ReadM a
auto
      ( [Mod ArgumentFields Format] -> Mod ArgumentFields Format
forall a. Monoid a => [a] -> a
mconcat
          [ FilePath -> Mod ArgumentFields Format
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"To format (Legacy, Mem or LMDB)"
          , FilePath -> Mod ArgumentFields Format
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"FORMAT-OUT"
          ]
      )
    Parser (FilePath -> Config) -> Parser FilePath -> Parser Config
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod ArgumentFields FilePath -> Parser FilePath
forall s. IsString s => Mod ArgumentFields s -> Parser s
strArgument
      ( [Mod ArgumentFields FilePath] -> Mod ArgumentFields FilePath
forall a. Monoid a => [a] -> a
mconcat
          [ FilePath -> Mod ArgumentFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Output dir/file Use relative paths like ./100007913"
          , FilePath -> Mod ArgumentFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"PATH-OUT"
          ]
      )

-- Helpers

pathToDiskSnapshot :: FilePath -> Maybe (SomeHasFS IO, FsPath, DiskSnapshot)
pathToDiskSnapshot :: FilePath -> Maybe (SomeHasFS IO, FsPath, DiskSnapshot)
pathToDiskSnapshot FilePath
path = (HasFS IO HandleIO -> SomeHasFS IO
forall h (m :: * -> *). Eq h => HasFS m h -> SomeHasFS m
SomeHasFS (HasFS IO HandleIO -> SomeHasFS IO)
-> HasFS IO HandleIO -> SomeHasFS IO
forall a b. (a -> b) -> a -> b
$ MountPoint -> HasFS IO HandleIO
forall (m :: * -> *).
(MonadIO m, PrimState IO ~ PrimState m) =>
MountPoint -> HasFS m HandleIO
ioHasFS (MountPoint -> HasFS IO HandleIO)
-> MountPoint -> HasFS IO HandleIO
forall a b. (a -> b) -> a -> b
$ FilePath -> MountPoint
MountPoint FilePath
dir,[FilePath] -> FsPath
mkFsPath [FilePath
file],) (DiskSnapshot -> (SomeHasFS IO, FsPath, DiskSnapshot))
-> Maybe DiskSnapshot -> Maybe (SomeHasFS IO, FsPath, DiskSnapshot)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Maybe DiskSnapshot
snapshotFromPath FilePath
file
 where
  (FilePath
dir, FilePath
file) = FilePath -> (FilePath, FilePath)
splitFileName FilePath
path

defaultLMDBLimits :: V1.LMDBLimits
defaultLMDBLimits :: LMDBLimits
defaultLMDBLimits =
  V1.LMDBLimits
    { lmdbMapSize :: Int
V1.lmdbMapSize = Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024
    , lmdbMaxDatabases :: Int
V1.lmdbMaxDatabases = Int
10
    , lmdbMaxReaders :: Int
V1.lmdbMaxReaders = Int
16
    }

data Error blk
  = SnapshotError (SnapshotFailure blk)
  | TablesCantDeserializeError DeserialiseFailure
  | TablesTrailingBytes
  | SnapshotFormatMismatch Format String
  | ReadSnapshotCRCError FsPath CRCError
  deriving Show (Error blk)
Typeable (Error blk)
(Typeable (Error blk), Show (Error blk)) =>
(Error blk -> SomeException)
-> (SomeException -> Maybe (Error blk))
-> (Error blk -> FilePath)
-> (Error blk -> Bool)
-> Exception (Error blk)
SomeException -> Maybe (Error blk)
Error blk -> Bool
Error blk -> FilePath
Error blk -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> FilePath)
-> (e -> Bool)
-> Exception e
forall blk. (StandardHash blk, Typeable blk) => Show (Error blk)
forall blk.
(StandardHash blk, Typeable blk) =>
Typeable (Error blk)
forall blk.
(StandardHash blk, Typeable blk) =>
SomeException -> Maybe (Error blk)
forall blk. (StandardHash blk, Typeable blk) => Error blk -> Bool
forall blk.
(StandardHash blk, Typeable blk) =>
Error blk -> FilePath
forall blk.
(StandardHash blk, Typeable blk) =>
Error blk -> SomeException
$ctoException :: forall blk.
(StandardHash blk, Typeable blk) =>
Error blk -> SomeException
toException :: Error blk -> SomeException
$cfromException :: forall blk.
(StandardHash blk, Typeable blk) =>
SomeException -> Maybe (Error blk)
fromException :: SomeException -> Maybe (Error blk)
$cdisplayException :: forall blk.
(StandardHash blk, Typeable blk) =>
Error blk -> FilePath
displayException :: Error blk -> FilePath
$cbacktraceDesired :: forall blk. (StandardHash blk, Typeable blk) => Error blk -> Bool
backtraceDesired :: Error blk -> Bool
Exception

instance StandardHash blk => Show (Error blk) where
  show :: Error blk -> FilePath
show (SnapshotError SnapshotFailure blk
err) =
    FilePath
"Couldn't deserialize the snapshot. Are you running the same node version that created the snapshot? "
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> SnapshotFailure blk -> FilePath
forall a. Show a => a -> FilePath
show SnapshotFailure blk
err
  show (TablesCantDeserializeError DeserialiseFailure
err) = FilePath
"Couldn't deserialize the tables: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> DeserialiseFailure -> FilePath
forall a. Show a => a -> FilePath
show DeserialiseFailure
err
  show Error blk
TablesTrailingBytes = FilePath
"Malformed tables, there are trailing bytes!"
  show (SnapshotFormatMismatch Format
expected FilePath
err) =
    FilePath
"The input snapshot does not seem to correspond to the input format:\n\t"
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Format -> FilePath
forall a. Show a => a -> FilePath
show Format
expected
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"\n\tThe provided path "
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
err
  show (ReadSnapshotCRCError FsPath
fp CRCError
err) = FilePath
"An error occurred while reading the snapshot checksum at " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FsPath -> FilePath
forall a. Show a => a -> FilePath
show FsPath
fp FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
": \n\t" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> CRCError -> FilePath
forall a. Show a => a -> FilePath
show CRCError
err

checkSnapshotFileStructure :: Format -> FsPath -> SomeHasFS IO -> ExceptT (Error blk) IO ()
checkSnapshotFileStructure :: forall blk.
Format -> FsPath -> SomeHasFS IO -> ExceptT (Error blk) IO ()
checkSnapshotFileStructure Format
m FsPath
p (SomeHasFS HasFS IO h
fs) = case Format
m of
  Format
Legacy -> (FsPath -> IO Bool)
-> FsPath -> FilePath -> ExceptT (Error blk) IO ()
forall blk.
(FsPath -> IO Bool)
-> FsPath -> FilePath -> ExceptT (Error blk) IO ()
want (HasFS IO h -> HasCallStack => FsPath -> IO Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesFileExist HasFS IO h
fs) FsPath
p FilePath
"is NOT a file"
  Format
Mem -> FilePath -> ExceptT (Error blk) IO ()
forall {blk}. FilePath -> ExceptT (Error blk) IO ()
newFormatCheck FilePath
"tvar"
  Format
LMDB -> FilePath -> ExceptT (Error blk) IO ()
forall {blk}. FilePath -> ExceptT (Error blk) IO ()
newFormatCheck FilePath
"data.mdb"
 where
  want :: (FsPath -> IO Bool) -> FsPath -> String -> ExceptT (Error blk) IO ()
  want :: forall blk.
(FsPath -> IO Bool)
-> FsPath -> FilePath -> ExceptT (Error blk) IO ()
want FsPath -> IO Bool
fileType FsPath
path FilePath
err = do
    exists <- IO Bool -> ExceptT (Error blk) IO Bool
forall (m :: * -> *) a. Monad m => m a -> ExceptT (Error blk) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (IO Bool -> ExceptT (Error blk) IO Bool)
-> IO Bool -> ExceptT (Error blk) IO Bool
forall a b. (a -> b) -> a -> b
$ FsPath -> IO Bool
fileType FsPath
path
    Monad.unless exists $ throwError $ SnapshotFormatMismatch m err

  isDir :: (HasFS m h -> FsPath -> m Bool, [a], FilePath)
isDir = (HasFS m h -> HasCallStack => FsPath -> m Bool
HasFS m h -> FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesDirectoryExist, [], FilePath
"is NOT a directory")
  hasTablesDir :: (HasFS m h -> FsPath -> m Bool, [FilePath], FilePath)
hasTablesDir = (HasFS m h -> HasCallStack => FsPath -> m Bool
HasFS m h -> FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesDirectoryExist, [FilePath
"tables"], FilePath
"DOES NOT contain a \"tables\" directory")
  hasState :: (HasFS m h -> FsPath -> m Bool, [FilePath], FilePath)
hasState = (HasFS m h -> HasCallStack => FsPath -> m Bool
HasFS m h -> FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesFileExist, [FilePath
"state"], FilePath
"DOES NOT contain a \"state\" file")
  hasTables :: c -> (HasFS m h -> FsPath -> m Bool, [c], c)
hasTables c
tb = (HasFS m h -> HasCallStack => FsPath -> m Bool
HasFS m h -> FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesFileExist, [c
"tables", c
tb], c
"DOES NOT contain a \"tables/" c -> c -> c
forall a. Semigroup a => a -> a -> a
<> c
tb c -> c -> c
forall a. Semigroup a => a -> a -> a
<> c
"\" file")

  newFormatCheck :: FilePath -> ExceptT (Error blk) IO ()
newFormatCheck FilePath
tb =
    ((HasFS IO h -> FsPath -> IO Bool, [FilePath], FilePath)
 -> ExceptT (Error blk) IO ())
-> [(HasFS IO h -> FsPath -> IO Bool, [FilePath], FilePath)]
-> ExceptT (Error blk) IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
      (\(HasFS IO h -> FsPath -> IO Bool
doCheck, [FilePath]
extra, FilePath
err) -> (FsPath -> IO Bool)
-> FsPath -> FilePath -> ExceptT (Error blk) IO ()
forall blk.
(FsPath -> IO Bool)
-> FsPath -> FilePath -> ExceptT (Error blk) IO ()
want (HasFS IO h -> FsPath -> IO Bool
doCheck HasFS IO h
fs) (FsPath
p FsPath -> FsPath -> FsPath
</> [FilePath] -> FsPath
mkFsPath [FilePath]
extra) FilePath
err)
      [ (HasFS IO h -> FsPath -> IO Bool, [FilePath], FilePath)
forall {m :: * -> *} {h} {a}.
(HasFS m h -> FsPath -> m Bool, [a], FilePath)
isDir
      , (HasFS IO h -> FsPath -> IO Bool, [FilePath], FilePath)
forall {m :: * -> *} {h}.
(HasFS m h -> FsPath -> m Bool, [FilePath], FilePath)
hasTablesDir
      , (HasFS IO h -> FsPath -> IO Bool, [FilePath], FilePath)
forall {m :: * -> *} {h}.
(HasFS m h -> FsPath -> m Bool, [FilePath], FilePath)
hasState
      , FilePath -> (HasFS IO h -> FsPath -> IO Bool, [FilePath], FilePath)
forall {c} {m :: * -> *} {h}.
(IsString c, Semigroup c) =>
c -> (HasFS m h -> FsPath -> m Bool, [c], c)
hasTables FilePath
tb
      ]

load ::
  forall blk.
  ( LedgerDbSerialiseConstraints blk
  , CanStowLedgerTables (LedgerState blk)
  , LedgerSupportsProtocol blk
  , LedgerSupportsLedgerDB blk
  ) =>
  Config ->
  ResourceRegistry IO ->
  CodecConfig blk ->
  FilePath ->
  ExceptT (Error blk) IO (ExtLedgerState blk EmptyMK, LedgerTables (ExtLedgerState blk) ValuesMK)
load :: forall blk.
(LedgerDbSerialiseConstraints blk,
 CanStowLedgerTables (LedgerState blk), LedgerSupportsProtocol blk,
 LedgerSupportsLedgerDB blk) =>
Config
-> ResourceRegistry IO
-> CodecConfig blk
-> FilePath
-> ExceptT
     (Error blk)
     IO
     (ExtLedgerState blk EmptyMK,
      LedgerTables (ExtLedgerState blk) ValuesMK)
load config :: Config
config@Config{inpath :: Config -> FilePath
inpath = FilePath -> Maybe (SomeHasFS IO, FsPath, DiskSnapshot)
pathToDiskSnapshot -> Just (fs :: SomeHasFS IO
fs@(SomeHasFS HasFS IO h
hasFS), FsPath
path, DiskSnapshot
ds)} ResourceRegistry IO
rr CodecConfig blk
ccfg FilePath
tempFP =
  case Config -> Format
from Config
config of
    Format
Legacy -> do
      Format -> FsPath -> SomeHasFS IO -> ExceptT (Error blk) IO ()
forall blk.
Format -> FsPath -> SomeHasFS IO -> ExceptT (Error blk) IO ()
checkSnapshotFileStructure Format
Legacy FsPath
path SomeHasFS IO
fs
      (st, checksumAsRead) <-
        (ExtLedgerState blk EmptyMK -> ExtLedgerState blk ValuesMK)
-> (ExtLedgerState blk EmptyMK, CRC)
-> (ExtLedgerState blk ValuesMK, CRC)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: MapKind) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ExtLedgerState blk EmptyMK -> ExtLedgerState blk ValuesMK
forall (l :: LedgerStateKind).
CanStowLedgerTables l =>
l EmptyMK -> l ValuesMK
unstowLedgerTables
          ((ExtLedgerState blk EmptyMK, CRC)
 -> (ExtLedgerState blk ValuesMK, CRC))
-> ExceptT (Error blk) IO (ExtLedgerState blk EmptyMK, CRC)
-> ExceptT (Error blk) IO (ExtLedgerState blk ValuesMK, CRC)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReadIncrementalErr -> Error blk)
-> ExceptT ReadIncrementalErr IO (ExtLedgerState blk EmptyMK, CRC)
-> ExceptT (Error blk) IO (ExtLedgerState blk EmptyMK, CRC)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT
            (SnapshotFailure blk -> Error blk
forall blk. SnapshotFailure blk -> Error blk
SnapshotError (SnapshotFailure blk -> Error blk)
-> (ReadIncrementalErr -> SnapshotFailure blk)
-> ReadIncrementalErr
-> Error blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadSnapshotErr -> SnapshotFailure blk
forall blk. ReadSnapshotErr -> SnapshotFailure blk
InitFailureRead (ReadSnapshotErr -> SnapshotFailure blk)
-> (ReadIncrementalErr -> ReadSnapshotErr)
-> ReadIncrementalErr
-> SnapshotFailure blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadIncrementalErr -> ReadSnapshotErr
ReadSnapshotFailed)
            (SomeHasFS IO
-> (forall s. Decoder s (ExtLedgerState blk EmptyMK))
-> (forall s. Decoder s (HeaderHash blk))
-> FsPath
-> ExceptT ReadIncrementalErr IO (ExtLedgerState blk EmptyMK, CRC)
forall (m :: * -> *) blk.
IOLike m =>
SomeHasFS m
-> (forall s. Decoder s (ExtLedgerState blk EmptyMK))
-> (forall s. Decoder s (HeaderHash blk))
-> FsPath
-> ExceptT ReadIncrementalErr m (ExtLedgerState blk EmptyMK, CRC)
readExtLedgerState SomeHasFS IO
fs (CodecConfig blk -> forall s. Decoder s (ExtLedgerState blk EmptyMK)
forall blk.
(DecodeDisk blk (LedgerState blk EmptyMK),
 DecodeDisk blk (ChainDepState (BlockProtocol blk)),
 DecodeDisk blk (AnnTip blk)) =>
CodecConfig blk -> forall s. Decoder s (ExtLedgerState blk EmptyMK)
decodeDiskExtLedgerState CodecConfig blk
ccfg) Decoder s (HeaderHash blk)
forall s. Decoder s (HeaderHash blk)
forall a s. Serialise a => Decoder s a
decode FsPath
path)
      let crcPath = FsPath
path FsPath -> FilePath -> FsPath
<.> FilePath
"checksum"
      crcFileExists <- Trans.lift $ doesFileExist hasFS crcPath
      Monad.when crcFileExists $ do
        snapshotCRC <-
          withExceptT (ReadSnapshotCRCError crcPath) $
            readCRC hasFS crcPath
        Monad.when (checksumAsRead /= snapshotCRC) $
          throwError $
            SnapshotError $
              InitFailureRead ReadSnapshotDataCorruption
      pure (forgetLedgerTables st, projectLedgerTables st)
    Format
Mem -> do
      Format -> FsPath -> SomeHasFS IO -> ExceptT (Error blk) IO ()
forall blk.
Format -> FsPath -> SomeHasFS IO -> ExceptT (Error blk) IO ()
checkSnapshotFileStructure Format
Mem FsPath
path SomeHasFS IO
fs
      (ls, _) <- (SnapshotFailure blk -> Error blk)
-> ExceptT
     (SnapshotFailure blk) IO (LedgerSeq' IO blk, RealPoint blk)
-> ExceptT (Error blk) IO (LedgerSeq' IO blk, RealPoint blk)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT SnapshotFailure blk -> Error blk
forall blk. SnapshotFailure blk -> Error blk
SnapshotError (ExceptT
   (SnapshotFailure blk) IO (LedgerSeq' IO blk, RealPoint blk)
 -> ExceptT (Error blk) IO (LedgerSeq' IO blk, RealPoint blk))
-> ExceptT
     (SnapshotFailure blk) IO (LedgerSeq' IO blk, RealPoint blk)
-> ExceptT (Error blk) IO (LedgerSeq' IO blk, RealPoint blk)
forall a b. (a -> b) -> a -> b
$ ResourceRegistry IO
-> CodecConfig blk
-> SomeHasFS IO
-> DiskSnapshot
-> ExceptT
     (SnapshotFailure blk) IO (LedgerSeq' IO blk, RealPoint blk)
forall blk (m :: * -> *).
(LedgerDbSerialiseConstraints blk, LedgerSupportsProtocol blk,
 IOLike m, LedgerSupportsInMemoryLedgerDB blk) =>
ResourceRegistry m
-> CodecConfig blk
-> SomeHasFS m
-> DiskSnapshot
-> ExceptT
     (SnapshotFailure blk) m (LedgerSeq' m blk, RealPoint blk)
V2.loadSnapshot ResourceRegistry IO
rr CodecConfig blk
ccfg SomeHasFS IO
fs DiskSnapshot
ds
      let h = LedgerSeq' IO blk -> StateRef IO (ExtLedgerState blk)
forall (l :: LedgerStateKind) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> StateRef m l
V2.currentHandle LedgerSeq' IO blk
ls
      (V2.state h,) <$> Trans.lift (V2.readAll (V2.tables h))
    Format
LMDB -> do
      Format -> FsPath -> SomeHasFS IO -> ExceptT (Error blk) IO ()
forall blk.
Format -> FsPath -> SomeHasFS IO -> ExceptT (Error blk) IO ()
checkSnapshotFileStructure Format
LMDB FsPath
path SomeHasFS IO
fs
      ((dbch, bstore), _) <-
        (SnapshotFailure blk -> Error blk)
-> ExceptT
     (SnapshotFailure blk)
     IO
     ((DbChangelog' blk, LedgerBackingStore IO (ExtLedgerState blk)),
      RealPoint blk)
-> ExceptT
     (Error blk)
     IO
     ((DbChangelog' blk, LedgerBackingStore IO (ExtLedgerState blk)),
      RealPoint blk)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT SnapshotFailure blk -> Error blk
forall blk. SnapshotFailure blk -> Error blk
SnapshotError (ExceptT
   (SnapshotFailure blk)
   IO
   ((DbChangelog' blk, LedgerBackingStore IO (ExtLedgerState blk)),
    RealPoint blk)
 -> ExceptT
      (Error blk)
      IO
      ((DbChangelog' blk, LedgerBackingStore IO (ExtLedgerState blk)),
       RealPoint blk))
-> ExceptT
     (SnapshotFailure blk)
     IO
     ((DbChangelog' blk, LedgerBackingStore IO (ExtLedgerState blk)),
      RealPoint blk)
-> ExceptT
     (Error blk)
     IO
     ((DbChangelog' blk, LedgerBackingStore IO (ExtLedgerState blk)),
      RealPoint blk)
forall a b. (a -> b) -> a -> b
$
          Tracer IO FlavorImplSpecificTrace
-> Complete BackingStoreArgs IO
-> CodecConfig blk
-> SnapshotsFS IO
-> DiskSnapshot
-> ExceptT
     (SnapshotFailure blk)
     IO
     ((DbChangelog' blk, LedgerBackingStore IO (ExtLedgerState blk)),
      RealPoint blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk, LedgerSupportsLedgerDB blk) =>
Tracer m FlavorImplSpecificTrace
-> Complete BackingStoreArgs m
-> CodecConfig blk
-> SnapshotsFS m
-> DiskSnapshot
-> ExceptT
     (SnapshotFailure blk)
     m
     ((DbChangelog' blk, LedgerBackingStore m (ExtLedgerState blk)),
      RealPoint blk)
V1.loadSnapshot
            Tracer IO FlavorImplSpecificTrace
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
            (FilePath
-> HKD Identity LMDBLimits
-> Dict MonadIOPrim IO
-> Complete BackingStoreArgs IO
forall (f :: * -> *) (m :: * -> *).
FilePath
-> HKD f LMDBLimits -> Dict MonadIOPrim m -> BackingStoreArgs f m
V1.LMDBBackingStoreArgs FilePath
tempFP HKD Identity LMDBLimits
LMDBLimits
defaultLMDBLimits Dict MonadIOPrim IO
forall {k} (c :: k -> Constraint) (a :: k). c a => Dict c a
Dict.Dict)
            CodecConfig blk
ccfg
            (SomeHasFS IO -> SnapshotsFS IO
forall (m :: * -> *). SomeHasFS m -> SnapshotsFS m
V1.SnapshotsFS SomeHasFS IO
fs)
            DiskSnapshot
ds
      (V1.current dbch,) <$> Trans.lift (V1.bsReadAll bstore (V1.changelogLastFlushedState dbch))
load Config
_ ResourceRegistry IO
_ CodecConfig blk
_ FilePath
_ = FilePath
-> ExceptT
     (Error blk)
     IO
     (ExtLedgerState blk EmptyMK,
      LedgerTables (ExtLedgerState blk) ValuesMK)
forall a. HasCallStack => FilePath -> a
error FilePath
"Malformed input path!"

store ::
  ( LedgerDbSerialiseConstraints blk
  , CanStowLedgerTables (LedgerState blk)
  , LedgerSupportsProtocol blk
  , LedgerSupportsLedgerDB blk
  ) =>
  Config ->
  CodecConfig blk ->
  (ExtLedgerState blk EmptyMK, LedgerTables (ExtLedgerState blk) ValuesMK) ->
  SomeHasFS IO ->
  IO ()
store :: forall blk.
(LedgerDbSerialiseConstraints blk,
 CanStowLedgerTables (LedgerState blk), LedgerSupportsProtocol blk,
 LedgerSupportsLedgerDB blk) =>
Config
-> CodecConfig blk
-> (ExtLedgerState blk EmptyMK,
    LedgerTables (ExtLedgerState blk) ValuesMK)
-> SomeHasFS IO
-> IO ()
store config :: Config
config@Config{outpath :: Config -> FilePath
outpath = FilePath -> Maybe (SomeHasFS IO, FsPath, DiskSnapshot)
pathToDiskSnapshot -> Just (fs :: SomeHasFS IO
fs@(SomeHasFS HasFS IO h
hasFS), FsPath
path, DiskSnapshot Word64
_ Maybe FilePath
suffix)} CodecConfig blk
ccfg (ExtLedgerState blk EmptyMK
state, LedgerTables (ExtLedgerState blk) ValuesMK
tbs) SomeHasFS IO
tempFS =
  case Config -> Format
to Config
config of
    Format
Legacy -> do
      crc <-
        SomeHasFS IO
-> (ExtLedgerState blk EmptyMK -> Encoding)
-> FsPath
-> ExtLedgerState blk EmptyMK
-> IO CRC
forall (m :: * -> *) blk.
MonadThrow m =>
SomeHasFS m
-> (ExtLedgerState blk EmptyMK -> Encoding)
-> FsPath
-> ExtLedgerState blk EmptyMK
-> m CRC
writeExtLedgerState
          SomeHasFS IO
fs
          (CodecConfig blk -> ExtLedgerState blk EmptyMK -> Encoding
forall blk.
(EncodeDisk blk (LedgerState blk EmptyMK),
 EncodeDisk blk (ChainDepState (BlockProtocol blk)),
 EncodeDisk blk (AnnTip blk)) =>
CodecConfig blk -> ExtLedgerState blk EmptyMK -> Encoding
encodeDiskExtLedgerState CodecConfig blk
ccfg)
          FsPath
path
          (ExtLedgerState blk ValuesMK -> ExtLedgerState blk EmptyMK
forall (l :: LedgerStateKind).
CanStowLedgerTables l =>
l ValuesMK -> l EmptyMK
stowLedgerTables (ExtLedgerState blk ValuesMK -> ExtLedgerState blk EmptyMK)
-> ExtLedgerState blk ValuesMK -> ExtLedgerState blk EmptyMK
forall a b. (a -> b) -> a -> b
$ ExtLedgerState blk EmptyMK
state ExtLedgerState blk EmptyMK
-> LedgerTables (ExtLedgerState blk) ValuesMK
-> ExtLedgerState blk ValuesMK
forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
ExtLedgerState blk any
-> LedgerTables (ExtLedgerState blk) mk -> ExtLedgerState blk mk
forall (l :: LedgerStateKind) (mk :: MapKind) (any :: MapKind).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l any -> LedgerTables l mk -> l mk
`withLedgerTables` LedgerTables (ExtLedgerState blk) ValuesMK
tbs)
      withFile hasFS (path <.> "checksum") (WriteMode MustBeNew) $ \Handle h
h ->
        IO Word64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
Monad.void (IO Word64 -> IO ()) -> IO Word64 -> IO ()
forall a b. (a -> b) -> a -> b
$ HasFS IO h -> Handle h -> ByteString -> IO Word64
forall (m :: * -> *) h.
(HasCallStack, Monad m) =>
HasFS m h -> Handle h -> ByteString -> m Word64
hPutAll HasFS IO h
hasFS Handle h
h (ByteString -> IO Word64)
-> (Word32 -> ByteString) -> Word32 -> IO Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BS.toLazyByteString (Builder -> ByteString)
-> (Word32 -> Builder) -> Word32 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Builder
BS.word32HexFixed (Word32 -> IO Word64) -> Word32 -> IO Word64
forall a b. (a -> b) -> a -> b
$ CRC -> Word32
getCRC CRC
crc
    Format
Mem -> do
      lseq <- ExtLedgerState blk EmptyMK
-> LedgerTables (ExtLedgerState blk) ValuesMK
-> (LedgerTables (ExtLedgerState blk) ValuesMK
    -> IO (LedgerTablesHandle IO (ExtLedgerState blk)))
-> IO (LedgerSeq IO (ExtLedgerState blk))
forall (l :: LedgerStateKind) (m :: * -> *).
(GetTip l, IOLike m) =>
l EmptyMK
-> LedgerTables l ValuesMK
-> (LedgerTables l ValuesMK -> m (LedgerTablesHandle m l))
-> m (LedgerSeq m l)
V2.empty ExtLedgerState blk EmptyMK
state LedgerTables (ExtLedgerState blk) ValuesMK
tbs ((LedgerTables (ExtLedgerState blk) ValuesMK
  -> IO (LedgerTablesHandle IO (ExtLedgerState blk)))
 -> IO (LedgerSeq IO (ExtLedgerState blk)))
-> (LedgerTables (ExtLedgerState blk) ValuesMK
    -> IO (LedgerTablesHandle IO (ExtLedgerState blk)))
-> IO (LedgerSeq IO (ExtLedgerState blk))
forall a b. (a -> b) -> a -> b
$ SomeHasFS IO
-> LedgerTables (ExtLedgerState blk) ValuesMK
-> IO (LedgerTablesHandle IO (ExtLedgerState blk))
forall (m :: * -> *) (l :: LedgerStateKind).
(IOLike m, HasLedgerTables l, CanUpgradeLedgerTables l,
 SerializeTablesWithHint l) =>
SomeHasFS m
-> LedgerTables l ValuesMK -> m (LedgerTablesHandle m l)
V2.newInMemoryLedgerTablesHandle SomeHasFS IO
fs
      let h = LedgerSeq IO (ExtLedgerState blk)
-> StateRef IO (ExtLedgerState blk)
forall (l :: LedgerStateKind) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> StateRef m l
V2.currentHandle LedgerSeq IO (ExtLedgerState blk)
lseq
      Monad.void $ V2.takeSnapshot ccfg nullTracer fs suffix h
    Format
LMDB -> do
      chlog <- DbChangelog (ExtLedgerState blk)
-> IO (StrictTVar IO (DbChangelog (ExtLedgerState blk)))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO (ExtLedgerState blk EmptyMK -> DbChangelog (ExtLedgerState blk)
forall (l :: LedgerStateKind).
(HasLedgerTables l, GetTip l) =>
l EmptyMK -> DbChangelog l
V1.empty ExtLedgerState blk EmptyMK
state)
      lock <- V1.mkLedgerDBLock
      bs <-
        V1.newLMDBBackingStore
          nullTracer
          defaultLMDBLimits
          (V1.LiveLMDBFS tempFS)
          (V1.SnapshotsFS fs)
          (V1.InitFromValues (pointSlot $ getTip state) state tbs)
      Monad.void $ V1.withReadLock lock $ do
        V1.takeSnapshot chlog ccfg nullTracer (V1.SnapshotsFS fs) bs suffix
store Config
_ CodecConfig blk
_ (ExtLedgerState blk EmptyMK,
 LedgerTables (ExtLedgerState blk) ValuesMK)
_ SomeHasFS IO
_ = FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error FilePath
"Malformed output path!"

main :: IO ()
IO ()
main = IO () -> IO ()
forall (m :: * -> *) r. (MonadIO m, MonadMask m) => m r -> m r
withStdTerminalHandles (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  IO ()
cryptoInit
  (conf, blocktype) <- IO (Config, BlockType)
getCommandLineConfig
  case blocktype of
    ByronBlock ByronBlockArgs
args -> Config -> ByronBlockArgs -> IO ()
forall {blk}.
(HasProtocolInfo blk, Serialise (HeaderHash blk),
 EncodeDisk blk (LedgerState blk EmptyMK),
 EncodeDisk blk (AnnTip blk),
 EncodeDisk blk (ChainDepState (BlockProtocol blk)),
 DecodeDisk blk (LedgerState blk EmptyMK),
 DecodeDisk blk (AnnTip blk),
 DecodeDisk blk (ChainDepState (BlockProtocol blk)),
 SerializeTablesWithHint (LedgerState blk),
 IndexedMemPack (LedgerState blk EmptyMK) (TxOut (LedgerState blk)),
 CanStowLedgerTables (LedgerState blk), LedgerSupportsProtocol blk,
 LedgerSupportsInMemoryLedgerDB blk) =>
Config -> Args blk -> IO ()
run Config
conf ByronBlockArgs
args
    ShelleyBlock ShelleyBlockArgs
args -> Config -> ShelleyBlockArgs -> IO ()
forall {blk}.
(HasProtocolInfo blk, Serialise (HeaderHash blk),
 EncodeDisk blk (LedgerState blk EmptyMK),
 EncodeDisk blk (AnnTip blk),
 EncodeDisk blk (ChainDepState (BlockProtocol blk)),
 DecodeDisk blk (LedgerState blk EmptyMK),
 DecodeDisk blk (AnnTip blk),
 DecodeDisk blk (ChainDepState (BlockProtocol blk)),
 SerializeTablesWithHint (LedgerState blk),
 IndexedMemPack (LedgerState blk EmptyMK) (TxOut (LedgerState blk)),
 CanStowLedgerTables (LedgerState blk), LedgerSupportsProtocol blk,
 LedgerSupportsInMemoryLedgerDB blk) =>
Config -> Args blk -> IO ()
run Config
conf ShelleyBlockArgs
args
    CardanoBlock CardanoBlockArgs
args -> Config -> CardanoBlockArgs -> IO ()
forall {blk}.
(HasProtocolInfo blk, Serialise (HeaderHash blk),
 EncodeDisk blk (LedgerState blk EmptyMK),
 EncodeDisk blk (AnnTip blk),
 EncodeDisk blk (ChainDepState (BlockProtocol blk)),
 DecodeDisk blk (LedgerState blk EmptyMK),
 DecodeDisk blk (AnnTip blk),
 DecodeDisk blk (ChainDepState (BlockProtocol blk)),
 SerializeTablesWithHint (LedgerState blk),
 IndexedMemPack (LedgerState blk EmptyMK) (TxOut (LedgerState blk)),
 CanStowLedgerTables (LedgerState blk), LedgerSupportsProtocol blk,
 LedgerSupportsInMemoryLedgerDB blk) =>
Config -> Args blk -> IO ()
run Config
conf CardanoBlockArgs
args
 where
  run :: Config -> Args blk -> IO ()
run Config
conf Args blk
args = do
    ccfg <- TopLevelConfig blk -> CodecConfig blk
forall blk. TopLevelConfig blk -> CodecConfig blk
configCodec (TopLevelConfig blk -> CodecConfig blk)
-> (ProtocolInfo blk -> TopLevelConfig blk)
-> ProtocolInfo blk
-> CodecConfig blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolInfo blk -> TopLevelConfig blk
forall b. ProtocolInfo b -> TopLevelConfig b
pInfoConfig (ProtocolInfo blk -> CodecConfig blk)
-> IO (ProtocolInfo blk) -> IO (CodecConfig blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Args blk -> IO (ProtocolInfo blk)
forall blk.
HasProtocolInfo blk =>
Args blk -> IO (ProtocolInfo blk)
mkProtocolInfo Args blk
args
    withSystemTempDirectory "lmdb" $ \FilePath
dir -> do
      let tempFS :: SomeHasFS IO
tempFS = HasFS IO HandleIO -> SomeHasFS IO
forall h (m :: * -> *). Eq h => HasFS m h -> SomeHasFS m
SomeHasFS (HasFS IO HandleIO -> SomeHasFS IO)
-> HasFS IO HandleIO -> SomeHasFS IO
forall a b. (a -> b) -> a -> b
$ MountPoint -> HasFS IO HandleIO
forall (m :: * -> *).
(MonadIO m, PrimState IO ~ PrimState m) =>
MountPoint -> HasFS m HandleIO
ioHasFS (MountPoint -> HasFS IO HandleIO)
-> MountPoint -> HasFS IO HandleIO
forall a b. (a -> b) -> a -> b
$ FilePath -> MountPoint
MountPoint FilePath
dir
      (ResourceRegistry IO -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
RR.withRegistry ((ResourceRegistry IO -> IO ()) -> IO ())
-> (ResourceRegistry IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ResourceRegistry IO
rr -> do
        FilePath -> IO ()
putStrLn FilePath
"Loading snapshot..."
        state <- (Error blk
 -> IO
      (ExtLedgerState blk EmptyMK,
       LedgerTables (ExtLedgerState blk) ValuesMK))
-> ((ExtLedgerState blk EmptyMK,
     LedgerTables (ExtLedgerState blk) ValuesMK)
    -> IO
         (ExtLedgerState blk EmptyMK,
          LedgerTables (ExtLedgerState blk) ValuesMK))
-> Either
     (Error blk)
     (ExtLedgerState blk EmptyMK,
      LedgerTables (ExtLedgerState blk) ValuesMK)
-> IO
     (ExtLedgerState blk EmptyMK,
      LedgerTables (ExtLedgerState blk) ValuesMK)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Error blk
-> IO
     (ExtLedgerState blk EmptyMK,
      LedgerTables (ExtLedgerState blk) ValuesMK)
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ExtLedgerState blk EmptyMK,
 LedgerTables (ExtLedgerState blk) ValuesMK)
-> IO
     (ExtLedgerState blk EmptyMK,
      LedgerTables (ExtLedgerState blk) ValuesMK)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (Error blk)
   (ExtLedgerState blk EmptyMK,
    LedgerTables (ExtLedgerState blk) ValuesMK)
 -> IO
      (ExtLedgerState blk EmptyMK,
       LedgerTables (ExtLedgerState blk) ValuesMK))
-> IO
     (Either
        (Error blk)
        (ExtLedgerState blk EmptyMK,
         LedgerTables (ExtLedgerState blk) ValuesMK))
-> IO
     (ExtLedgerState blk EmptyMK,
      LedgerTables (ExtLedgerState blk) ValuesMK)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT
  (Error blk)
  IO
  (ExtLedgerState blk EmptyMK,
   LedgerTables (ExtLedgerState blk) ValuesMK)
-> IO
     (Either
        (Error blk)
        (ExtLedgerState blk EmptyMK,
         LedgerTables (ExtLedgerState blk) ValuesMK))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (Config
-> ResourceRegistry IO
-> CodecConfig blk
-> FilePath
-> ExceptT
     (Error blk)
     IO
     (ExtLedgerState blk EmptyMK,
      LedgerTables (ExtLedgerState blk) ValuesMK)
forall blk.
(LedgerDbSerialiseConstraints blk,
 CanStowLedgerTables (LedgerState blk), LedgerSupportsProtocol blk,
 LedgerSupportsLedgerDB blk) =>
Config
-> ResourceRegistry IO
-> CodecConfig blk
-> FilePath
-> ExceptT
     (Error blk)
     IO
     (ExtLedgerState blk EmptyMK,
      LedgerTables (ExtLedgerState blk) ValuesMK)
load Config
conf ResourceRegistry IO
rr CodecConfig blk
ccfg FilePath
dir)
        putStrLn "Loaded snapshot"
        putStrLn "Writing snapshot..."
        store conf ccfg state tempFS
        putStrLn "Written snapshot"