{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# 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 Control.Monad.Trans (lift)
import Control.ResourceRegistry
import DBAnalyser.Parsers
import Data.Bifunctor
import Data.Char (toLower)
import qualified Data.Text.Lazy as T
import Main.Utf8
import Options.Applicative
import Options.Applicative.Help (Doc, line)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Cardano.Block
import Ouroboros.Consensus.Cardano.StreamingLedgerTables
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 hiding (yield)
import System.Console.ANSI
import qualified System.Directory as D
import System.Exit
import System.FS.API
import System.FS.CRC
import System.FS.IO
import System.FilePath (splitDirectories)
import qualified System.FilePath as F
import System.IO
import System.ProgressBar
import System.Random

data Format
  = Mem FilePath
  | LMDB FilePath
  | LSM FilePath FilePath
  deriving (Int -> Format -> ShowS
[Format] -> ShowS
Format -> String
(Int -> Format -> ShowS)
-> (Format -> String) -> ([Format] -> ShowS) -> Show Format
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Format -> ShowS
showsPrec :: Int -> Format -> ShowS
$cshow :: Format -> String
show :: Format -> String
$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 -> Format
to :: Format
  -- ^ Which format the output snapshot must be in
  }

getCommandLineConfig :: IO (Config, CardanoBlockArgs)
getCommandLineConfig :: IO (Config, CardanoBlockArgs)
getCommandLineConfig =
  ParserInfo (Config, CardanoBlockArgs)
-> IO (Config, CardanoBlockArgs)
forall a. ParserInfo a -> IO a
execParser (ParserInfo (Config, CardanoBlockArgs)
 -> IO (Config, CardanoBlockArgs))
-> ParserInfo (Config, CardanoBlockArgs)
-> IO (Config, CardanoBlockArgs)
forall a b. (a -> b) -> a -> b
$
    Parser (Config, CardanoBlockArgs)
-> InfoMod (Config, CardanoBlockArgs)
-> ParserInfo (Config, CardanoBlockArgs)
forall a. Parser a -> InfoMod a -> ParserInfo a
info
      ((,) (Config -> CardanoBlockArgs -> (Config, CardanoBlockArgs))
-> Parser Config
-> Parser (CardanoBlockArgs -> (Config, CardanoBlockArgs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Format -> Format -> Config
Config (Format -> Format -> Config)
-> Parser Format -> Parser (Format -> Config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InOut -> Parser Format
parseConfig InOut
In Parser (Format -> Config) -> Parser Format -> 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
<*> InOut -> Parser Format
parseConfig InOut
Out) Parser (CardanoBlockArgs -> (Config, CardanoBlockArgs))
-> Parser CardanoBlockArgs -> Parser (Config, CardanoBlockArgs)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser CardanoBlockArgs
parseCardanoArgs Parser (Config, CardanoBlockArgs)
-> Parser
     ((Config, CardanoBlockArgs) -> (Config, CardanoBlockArgs))
-> Parser (Config, CardanoBlockArgs)
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser ((Config, CardanoBlockArgs) -> (Config, CardanoBlockArgs))
forall a. Parser (a -> a)
helper)
      ( InfoMod (Config, CardanoBlockArgs)
forall a. InfoMod a
fullDesc
          InfoMod (Config, CardanoBlockArgs)
-> InfoMod (Config, CardanoBlockArgs)
-> InfoMod (Config, CardanoBlockArgs)
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod (Config, CardanoBlockArgs)
forall a. String -> InfoMod a
header String
"Utility for converting snapshots among the different snapshot formats used by cardano-node."
          InfoMod (Config, CardanoBlockArgs)
-> InfoMod (Config, CardanoBlockArgs)
-> InfoMod (Config, CardanoBlockArgs)
forall a. Semigroup a => a -> a -> a
<> Maybe Doc -> InfoMod (Config, CardanoBlockArgs)
forall a. Maybe Doc -> InfoMod a
progDescDoc Maybe Doc
programDescription
      )

programDescription :: Maybe Doc
programDescription :: Maybe Doc
programDescription =
  Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc) -> Doc -> Maybe Doc
forall a b. (a -> b) -> a -> b
$
    [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat
      [ Doc
"The input snapshot must correspond to a snapshot that was produced by "
      , Doc
"a cardano-node, and thus follows the naming convention used in the node."
      , Doc
forall ann. Doc ann
line
      , Doc
"This means in particular that the filepath to the snapshot must have as "
      , Doc
"the last fragment a directory named after the slot number of the ledger "
      , Doc
"state snapshotted, plus an optional suffix, joined by an underscore."
      , Doc
forall ann. Doc ann
line
      , Doc
forall ann. Doc ann
line
      , Doc
"For the output, the same convention is enforced, so that the produced "
      , Doc
"snapshot can be loaded right away by a cardano-node."
      , Doc
forall ann. Doc ann
line
      , Doc
forall ann. Doc ann
line
      , Doc
"Note that snapshots that have a suffix will be preserved by the node. "
      , Doc
"If you produce a snapshot with a suffix and you start a node with it, "
      , Doc
"the node will take as many more snapshots as it is configured to take, "
      , Doc
"but it will never delete your snapshot, because it has a suffix on the name."
      , Doc
forall ann. Doc ann
line
      , Doc
"Therefore, for the most common use case it is advisable to create a "
      , Doc
"snapshot without a suffix, as in:"
      , Doc
forall ann. Doc ann
line
      , Doc
forall ann. Doc ann
line
      , Doc
"```"
      , Doc
forall ann. Doc ann
line
      , Doc
"$ mkdir out"
      , Doc
forall ann. Doc ann
line
      , Doc
"$ snapshot-converter --<fmt>-in <some-path>/<slot> --<fmt>-out out/<slot> --config <path-to-config.json>"
      , Doc
forall ann. Doc ann
line
      , Doc
"```"
      ]

data InOut = In | Out

inoutForGroup :: InOut -> String
inoutForGroup :: InOut -> String
inoutForGroup InOut
In = String
"Input arguments:"
inoutForGroup InOut
Out = String
"Output arguments:"

inoutForHelp :: InOut -> String -> Bool -> String
inoutForHelp :: InOut -> String -> Bool -> String
inoutForHelp InOut
In String
s Bool
b =
  [String] -> String
forall a. Monoid a => [a] -> a
mconcat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    (String
"Input " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s)
      String -> [String] -> [String]
forall a. a -> [a] -> [a]
: if Bool
b
        then
          [ String
". Must be a filepath where the last fragment is named after the "
          , String
"slot of the snapshotted state plus an optional suffix. Example: `1645330287_suffix`."
          ]
        else []
inoutForHelp InOut
Out String
s Bool
b =
  [String] -> String
forall a. Monoid a => [a] -> a
mconcat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    (String
"Output " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s)
      String -> [String] -> [String]
forall a. a -> [a] -> [a]
: if Bool
b
        then
          [ String
". Must be a filepath where the last fragment is named after the "
          , String
"slot of the snapshotted state plus an optional suffix. Example: `1645330287_suffix`."
          ]
        else []

inoutForCommand :: InOut -> String -> String
inoutForCommand :: InOut -> ShowS
inoutForCommand InOut
In = (String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-in")
inoutForCommand InOut
Out = (String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-out")

parseConfig :: InOut -> Parser Format
parseConfig :: InOut -> Parser Format
parseConfig InOut
io =
  ( String -> Format
Mem
      (String -> Format) -> Parser String -> Parser Format
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Parser String -> Parser String
forall a. String -> Parser a -> Parser a
parserOptionGroup
        (InOut -> String
inoutForGroup InOut
io)
        (String -> String -> Parser String
parsePath (InOut -> ShowS
inoutForCommand InOut
io String
"mem") (InOut -> String -> Bool -> String
inoutForHelp InOut
io String
"snapshot dir" Bool
True))
  )
    Parser Format -> Parser Format -> Parser Format
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ( String -> Format
LMDB
            (String -> Format) -> Parser String -> Parser Format
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Parser String -> Parser String
forall a. String -> Parser a -> Parser a
parserOptionGroup
              (InOut -> String
inoutForGroup InOut
io)
              (String -> String -> Parser String
parsePath (InOut -> ShowS
inoutForCommand InOut
io String
"lmdb") (InOut -> String -> Bool -> String
inoutForHelp InOut
io String
"snapshot dir" Bool
True))
        )
    Parser Format -> Parser Format -> Parser Format
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ( String -> String -> Format
LSM
            (String -> String -> Format)
-> Parser String -> Parser (String -> Format)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Parser String -> Parser String
forall a. String -> Parser a -> Parser a
parserOptionGroup
              (InOut -> String
inoutForGroup InOut
io)
              (String -> String -> Parser String
parsePath (InOut -> ShowS
inoutForCommand InOut
io String
"lsm-snapshot") (InOut -> String -> Bool -> String
inoutForHelp InOut
io String
"snapshot dir" Bool
True))
            Parser (String -> Format) -> Parser String -> Parser Format
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Parser String -> Parser String
forall a. String -> Parser a -> Parser a
parserOptionGroup
              (InOut -> String
inoutForGroup InOut
io)
              (String -> String -> Parser String
parsePath (InOut -> ShowS
inoutForCommand InOut
io String
"lsm-database") (InOut -> String -> Bool -> String
inoutForHelp InOut
io String
"LSM database" Bool
False))
        )

parsePath :: String -> String -> Parser FilePath
parsePath :: String -> String -> Parser String
parsePath String
optName String
strHelp =
  Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
    ( [Mod OptionFields String] -> Mod OptionFields String
forall a. Monoid a => [a] -> a
mconcat
        [ String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
optName
        , String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
strHelp
        , String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"PATH"
        ]
    )

data Error blk
  = SnapshotError (SnapshotFailure blk)
  | BadDirectoryName FilePath
  | WrongSlotDirectoryName FilePath SlotNo
  | InvalidMetadata String
  | BackendMismatch SnapshotBackend SnapshotBackend
  | CRCMismatch CRC CRC
  | ReadTablesError DeserialiseFailure
  | Cancelled
  deriving Show (Error blk)
Typeable (Error blk)
(Typeable (Error blk), Show (Error blk)) =>
(Error blk -> SomeException)
-> (SomeException -> Maybe (Error blk))
-> (Error blk -> String)
-> (Error blk -> Bool)
-> Exception (Error blk)
SomeException -> Maybe (Error blk)
Error blk -> Bool
Error blk -> String
Error blk -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (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 -> String
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 -> String
displayException :: Error blk -> String
$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 -> String
show (SnapshotError SnapshotFailure blk
err) =
    String
"Couldn't deserialize the snapshot. Are you running the same node version that created the snapshot? "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SnapshotFailure blk -> String
forall a. Show a => a -> String
show SnapshotFailure blk
err
  show (BadDirectoryName String
fp) =
    [String] -> String
forall a. Monoid a => [a] -> a
mconcat
      [ String
"Filepath "
      , String
fp
      , String
" is not an snapshot. The last fragment on the path should be"
      , String
" named after the slot number of the state it contains and an"
      , String
" optional suffix, such as `163470034` or `163470034_my-suffix`."
      ]
  show (InvalidMetadata String
s) = String
"Metadata is invalid: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s
  show (BackendMismatch SnapshotBackend
b1 SnapshotBackend
b2) =
    [String] -> String
forall a. Monoid a => [a] -> a
mconcat
      [ String
"Mismatched backend in snapshot. Reading as "
      , SnapshotBackend -> String
forall a. Show a => a -> String
show SnapshotBackend
b1
      , String
" but snapshot is "
      , SnapshotBackend -> String
forall a. Show a => a -> String
show SnapshotBackend
b2
      ]
  show (WrongSlotDirectoryName String
fp SlotNo
sl) =
    [String] -> String
forall a. Monoid a => [a] -> a
mconcat
      [ String
"The name of the snapshot (\""
      , String
fp
      , String
"\") does not correspond to the slot number of the state ("
      , (Word64 -> String
forall a. Show a => a -> String
show (Word64 -> String) -> (SlotNo -> Word64) -> SlotNo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> Word64
unSlotNo (SlotNo -> String) -> SlotNo -> String
forall a b. (a -> b) -> a -> b
$ SlotNo
sl)
      , String
")."
      ]
  show (CRCMismatch CRC
c1 CRC
c2) =
    [String] -> String
forall a. Monoid a => [a] -> a
mconcat
      [ String
"The input snapshot seems corrupted. Metadata has CRC "
      , CRC -> String
forall a. Show a => a -> String
show CRC
c1
      , String
" but reading it gives CRC "
      , CRC -> String
forall a. Show a => a -> String
show CRC
c2
      ]
  show (ReadTablesError DeserialiseFailure
df) =
    [String] -> String
forall a. Monoid a => [a] -> a
mconcat
      [String
"Error when reading entries in the UTxO tables: ", DeserialiseFailure -> String
forall a. Show a => a -> String
show DeserialiseFailure
df]
  show Error blk
Cancelled = String
"Cancelled"

data InEnv backend = InEnv
  { forall backend.
InEnv backend -> LedgerState (CardanoBlock StandardCrypto) EmptyMK
inState :: LedgerState (CardanoBlock StandardCrypto) EmptyMK
  , forall backend. InEnv backend -> String
inFilePath :: FilePath
  , forall backend.
InEnv backend
-> LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> ResourceRegistry IO
-> IO (SomeBackend YieldArgs)
inStream ::
      LedgerState (CardanoBlock StandardCrypto) EmptyMK ->
      ResourceRegistry IO ->
      IO (SomeBackend YieldArgs)
  , forall backend. InEnv backend -> String
inProgressMsg :: String
  , forall backend. InEnv backend -> CRC
inCRC :: CRC
  , forall backend. InEnv backend -> Maybe CRC
inSnapReadCRC :: Maybe CRC
  }

data SomeBackend c where
  SomeBackend ::
    StreamingBackend IO backend (LedgerState (CardanoBlock StandardCrypto)) =>
    c IO backend (LedgerState (CardanoBlock StandardCrypto)) -> SomeBackend c

data OutEnv backend = OutEnv
  { forall backend. OutEnv backend -> String
outFilePath :: FilePath
  , forall backend.
OutEnv backend
-> LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> ResourceRegistry IO
-> IO (SomeBackend SinkArgs)
outStream ::
      LedgerState (CardanoBlock StandardCrypto) EmptyMK ->
      ResourceRegistry IO ->
      IO (SomeBackend SinkArgs)
  , forall backend. OutEnv backend -> Maybe String
outCreateExtra :: Maybe FilePath
  , forall backend. OutEnv backend -> Maybe String
outDeleteExtra :: Maybe FilePath
  , forall backend. OutEnv backend -> String
outProgressMsg :: String
  , forall backend. OutEnv backend -> SnapshotBackend
outBackend :: SnapshotBackend
  }

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
  eRes <- ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
-> IO (Either (Error (CardanoBlock StandardCrypto)) ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
main'
  case eRes of
    Left Error (CardanoBlock StandardCrypto)
err -> do
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Error (CardanoBlock StandardCrypto) -> String
forall a. Show a => a -> String
show Error (CardanoBlock StandardCrypto)
err
      IO ()
forall a. IO a
exitFailure
    Right () -> IO ()
forall a. IO a
exitSuccess
 where
  main' :: ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
main' = do
    IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Error (CardanoBlock StandardCrypto)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ())
-> IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
cryptoInit
    (conf, args) <- IO (Config, CardanoBlockArgs)
-> ExceptT
     (Error (CardanoBlock StandardCrypto)) IO (Config, CardanoBlockArgs)
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Error (CardanoBlock StandardCrypto)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Config, CardanoBlockArgs)
 -> ExceptT
      (Error (CardanoBlock StandardCrypto))
      IO
      (Config, CardanoBlockArgs))
-> IO (Config, CardanoBlockArgs)
-> ExceptT
     (Error (CardanoBlock StandardCrypto)) IO (Config, CardanoBlockArgs)
forall a b. (a -> b) -> a -> b
$ IO (Config, CardanoBlockArgs)
getCommandLineConfig
    ccfg <- lift $ configCodec . pInfoConfig <$> mkProtocolInfo args

    InEnv{..} <- getInEnv ccfg (from conf)

    o@OutEnv{..} <- getOutEnv inState (to conf)

    wipeOutputPaths o

    lift $ putStr "Copying state file..." >> hFlush stdout
    lift $ D.copyFile (inFilePath F.</> "state") (outFilePath F.</> "state")
    lift $ putColored Green True "Done"

    lift $ putStr "Streaming ledger tables..." >> hFlush stdout >> saveCursor

    tid <- lift $ niceAnimatedProgressBar inProgressMsg outProgressMsg

    eRes <- lift $ runExceptT (stream inState inStream outStream)

    case eRes of
      Left DeserialiseFailure
err -> Error (CardanoBlock StandardCrypto)
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall a.
Error (CardanoBlock StandardCrypto)
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error (CardanoBlock StandardCrypto)
 -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ())
-> Error (CardanoBlock StandardCrypto)
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall a b. (a -> b) -> a -> b
$ DeserialiseFailure -> Error (CardanoBlock StandardCrypto)
forall blk. DeserialiseFailure -> Error blk
ReadTablesError DeserialiseFailure
err
      Right (Maybe CRC
mCRCIn, Maybe CRC
mCRCOut) -> do
        IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Error (CardanoBlock StandardCrypto)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ())
-> IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> (Async () -> IO ()) -> Maybe (Async ()) -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Async () -> IO ()
Async IO () -> IO ()
forall a. Async IO a -> IO ()
forall (m :: * -> *) a. MonadAsync m => Async m a -> m ()
cancel Maybe (Async ())
tid
        IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Error (CardanoBlock StandardCrypto)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ())
-> IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
clearLine IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
restoreCursor IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
cursorUp Int
1 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Color -> Bool -> String -> IO ()
putColored Color
Green Bool
True String
"Done"
        let crcIn :: CRC
crcIn = CRC -> (CRC -> CRC) -> Maybe CRC -> CRC
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CRC
inCRC (CRC -> CRC -> CRC
crcOfConcat CRC
inCRC) Maybe CRC
mCRCIn
        ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
-> (CRC -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ())
-> Maybe CRC
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          ( IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Error (CardanoBlock StandardCrypto)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ())
-> IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall a b. (a -> b) -> a -> b
$
              Color -> Bool -> String -> IO ()
putColored Color
Yellow Bool
True String
"The metadata file is missing, the snapshot is not guaranteed to be correct!"
          )
          ( \CRC
cs ->
              Bool
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.when (CRC
cs CRC -> CRC -> Bool
forall a. Eq a => a -> a -> Bool
/= CRC
crcIn) (ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
 -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ())
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall a b. (a -> b) -> a -> b
$ Error (CardanoBlock StandardCrypto)
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall a.
Error (CardanoBlock StandardCrypto)
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error (CardanoBlock StandardCrypto)
 -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ())
-> Error (CardanoBlock StandardCrypto)
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall a b. (a -> b) -> a -> b
$ CRC -> CRC -> Error (CardanoBlock StandardCrypto)
forall blk. CRC -> CRC -> Error blk
CRCMismatch CRC
cs CRC
crcIn
          )
          Maybe CRC
inSnapReadCRC

        let crcOut :: CRC
crcOut = CRC -> (CRC -> CRC) -> Maybe CRC -> CRC
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CRC
inCRC (CRC -> CRC -> CRC
crcOfConcat CRC
inCRC) Maybe CRC
mCRCOut

        IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Error (CardanoBlock StandardCrypto)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ())
-> IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
"Generating new metadata file..." IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
        String
-> SnapshotMetadata
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
putMetadata String
outFilePath (SnapshotBackend -> CRC -> TablesCodecVersion -> SnapshotMetadata
SnapshotMetadata SnapshotBackend
outBackend CRC
crcOut TablesCodecVersion
TablesCodecVersion1)

        IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Error (CardanoBlock StandardCrypto)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ())
-> IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall a b. (a -> b) -> a -> b
$ Color -> Bool -> String -> IO ()
putColored Color
Green Bool
True String
"Done"

  wipeOutputPaths :: OutEnv backend
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
wipeOutputPaths OutEnv{String
Maybe String
SnapshotBackend
LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> ResourceRegistry IO -> IO (SomeBackend SinkArgs)
outFilePath :: forall backend. OutEnv backend -> String
outStream :: forall backend.
OutEnv backend
-> LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> ResourceRegistry IO
-> IO (SomeBackend SinkArgs)
outCreateExtra :: forall backend. OutEnv backend -> Maybe String
outDeleteExtra :: forall backend. OutEnv backend -> Maybe String
outProgressMsg :: forall backend. OutEnv backend -> String
outBackend :: forall backend. OutEnv backend -> SnapshotBackend
outFilePath :: String
outStream :: LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> ResourceRegistry IO -> IO (SomeBackend SinkArgs)
outCreateExtra :: Maybe String
outDeleteExtra :: Maybe String
outProgressMsg :: String
outBackend :: SnapshotBackend
..} = do
    String -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
wipePath String
outFilePath
    IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Error (CardanoBlock StandardCrypto)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ())
-> IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> (String -> IO ()) -> Maybe String -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (String -> IO ()
D.createDirectory (String -> IO ()) -> ShowS -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
outFilePath String -> ShowS
F.</>)) Maybe String
outCreateExtra
    ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
-> (String -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ())
-> Maybe String
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (() -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall a. a -> ExceptT (Error (CardanoBlock StandardCrypto)) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
      String -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
wipePath
      Maybe String
outDeleteExtra

  getState :: CodecConfig blk -> String -> t IO (LedgerState blk EmptyMK, CRC)
getState CodecConfig blk
ccfg fp :: String
fp@(String -> SomeHasFS IO
pathToHasFS -> SomeHasFS IO
fs) = do
    eState <- IO (Either ReadIncrementalErr (ExtLedgerState blk EmptyMK, CRC))
-> t IO
     (Either ReadIncrementalErr (ExtLedgerState blk EmptyMK, CRC))
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Either ReadIncrementalErr (ExtLedgerState blk EmptyMK, CRC))
 -> t IO
      (Either ReadIncrementalErr (ExtLedgerState blk EmptyMK, CRC)))
-> IO (Either ReadIncrementalErr (ExtLedgerState blk EmptyMK, CRC))
-> t IO
     (Either ReadIncrementalErr (ExtLedgerState blk EmptyMK, CRC))
forall a b. (a -> b) -> a -> b
$ do
      String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Reading ledger state from " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (String
fp String -> ShowS
F.</> String
"state") String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"..."
      Handle -> IO ()
hFlush Handle
stdout
      ExceptT ReadIncrementalErr IO (ExtLedgerState blk EmptyMK, CRC)
-> IO (Either ReadIncrementalErr (ExtLedgerState blk EmptyMK, CRC))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (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 ([String] -> FsPath
mkFsPath [String
"state"]))
    case eState of
      Left ReadIncrementalErr
err ->
        Error (CardanoBlock StandardCrypto)
-> t IO (LedgerState blk EmptyMK, CRC)
forall a. Error (CardanoBlock StandardCrypto) -> t IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error (CardanoBlock StandardCrypto)
 -> t IO (LedgerState blk EmptyMK, CRC))
-> (ReadIncrementalErr -> Error (CardanoBlock StandardCrypto))
-> ReadIncrementalErr
-> t IO (LedgerState blk EmptyMK, CRC)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapshotFailure (CardanoBlock StandardCrypto)
-> Error (CardanoBlock StandardCrypto)
forall blk. SnapshotFailure blk -> Error blk
SnapshotError (SnapshotFailure (CardanoBlock StandardCrypto)
 -> Error (CardanoBlock StandardCrypto))
-> (ReadIncrementalErr
    -> SnapshotFailure (CardanoBlock StandardCrypto))
-> ReadIncrementalErr
-> Error (CardanoBlock StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall blk. ReadSnapshotErr -> SnapshotFailure blk
InitFailureRead @(CardanoBlock StandardCrypto) (ReadSnapshotErr -> SnapshotFailure (CardanoBlock StandardCrypto))
-> (ReadIncrementalErr -> ReadSnapshotErr)
-> ReadIncrementalErr
-> SnapshotFailure (CardanoBlock StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadIncrementalErr -> ReadSnapshotErr
ReadSnapshotFailed (ReadIncrementalErr -> t IO (LedgerState blk EmptyMK, CRC))
-> ReadIncrementalErr -> t IO (LedgerState blk EmptyMK, CRC)
forall a b. (a -> b) -> a -> b
$
          ReadIncrementalErr
err
      Right (ExtLedgerState blk EmptyMK, CRC)
st -> IO (LedgerState blk EmptyMK, CRC)
-> t IO (LedgerState blk EmptyMK, CRC)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (LedgerState blk EmptyMK, CRC)
 -> t IO (LedgerState blk EmptyMK, CRC))
-> IO (LedgerState blk EmptyMK, CRC)
-> t IO (LedgerState blk EmptyMK, CRC)
forall a b. (a -> b) -> a -> b
$ do
        Color -> Bool -> String -> IO ()
putColored Color
Green Bool
True String
" Done"
        (LedgerState blk EmptyMK, CRC) -> IO (LedgerState blk EmptyMK, CRC)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((LedgerState blk EmptyMK, CRC)
 -> IO (LedgerState blk EmptyMK, CRC))
-> ((ExtLedgerState blk EmptyMK, CRC)
    -> (LedgerState blk EmptyMK, CRC))
-> (ExtLedgerState blk EmptyMK, CRC)
-> IO (LedgerState blk EmptyMK, CRC)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK)
-> (ExtLedgerState blk EmptyMK, CRC)
-> (LedgerState blk EmptyMK, 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 -> LedgerState blk EmptyMK
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState ((ExtLedgerState blk EmptyMK, CRC)
 -> IO (LedgerState blk EmptyMK, CRC))
-> (ExtLedgerState blk EmptyMK, CRC)
-> IO (LedgerState blk EmptyMK, CRC)
forall a b. (a -> b) -> a -> b
$ (ExtLedgerState blk EmptyMK, CRC)
st

  getMetadata :: String
-> SnapshotBackend
-> ExceptT
     (Error (CardanoBlock StandardCrypto)) IO (Maybe CRC, DiskSnapshot)
getMetadata String
fp SnapshotBackend
bknd = do
    (fs, ds) <- String
-> ExceptT
     (Error (CardanoBlock StandardCrypto))
     IO
     (SomeHasFS IO, DiskSnapshot)
toDiskSnapshot String
fp
    mtd <-
      lift $ runExceptT $ loadSnapshotMetadata fs ds
    (,ds)
      <$> either
        ( \case
            MetadataErr
MetadataFileDoesNotExist -> Maybe CRC
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO (Maybe CRC)
forall a. a -> ExceptT (Error (CardanoBlock StandardCrypto)) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CRC
forall a. Maybe a
Nothing
            MetadataInvalid String
s -> Error (CardanoBlock StandardCrypto)
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO (Maybe CRC)
forall a.
Error (CardanoBlock StandardCrypto)
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error (CardanoBlock StandardCrypto)
 -> ExceptT (Error (CardanoBlock StandardCrypto)) IO (Maybe CRC))
-> Error (CardanoBlock StandardCrypto)
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO (Maybe CRC)
forall a b. (a -> b) -> a -> b
$ String -> Error (CardanoBlock StandardCrypto)
forall blk. String -> Error blk
InvalidMetadata String
s
            MetadataErr
MetadataBackendMismatch -> String
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO (Maybe CRC)
forall a. HasCallStack => String -> a
error String
"impossible"
        )
        ( \SnapshotMetadata
mtd' -> do
            if SnapshotBackend
bknd SnapshotBackend -> SnapshotBackend -> Bool
forall a. Eq a => a -> a -> Bool
/= SnapshotMetadata -> SnapshotBackend
snapshotBackend SnapshotMetadata
mtd'
              then Error (CardanoBlock StandardCrypto)
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO (Maybe CRC)
forall a.
Error (CardanoBlock StandardCrypto)
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error (CardanoBlock StandardCrypto)
 -> ExceptT (Error (CardanoBlock StandardCrypto)) IO (Maybe CRC))
-> Error (CardanoBlock StandardCrypto)
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO (Maybe CRC)
forall a b. (a -> b) -> a -> b
$ SnapshotBackend
-> SnapshotBackend -> Error (CardanoBlock StandardCrypto)
forall blk. SnapshotBackend -> SnapshotBackend -> Error blk
BackendMismatch SnapshotBackend
bknd (SnapshotMetadata -> SnapshotBackend
snapshotBackend SnapshotMetadata
mtd')
              else Maybe CRC
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO (Maybe CRC)
forall a. a -> ExceptT (Error (CardanoBlock StandardCrypto)) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe CRC
 -> ExceptT (Error (CardanoBlock StandardCrypto)) IO (Maybe CRC))
-> Maybe CRC
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO (Maybe CRC)
forall a b. (a -> b) -> a -> b
$ CRC -> Maybe CRC
forall a. a -> Maybe a
Just (CRC -> Maybe CRC) -> CRC -> Maybe CRC
forall a b. (a -> b) -> a -> b
$ SnapshotMetadata -> CRC
snapshotChecksum SnapshotMetadata
mtd'
        )
        mtd

  putMetadata :: String
-> SnapshotMetadata
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
putMetadata String
fp SnapshotMetadata
bknd = do
    (fs, ds) <- String
-> ExceptT
     (Error (CardanoBlock StandardCrypto))
     IO
     (SomeHasFS IO, DiskSnapshot)
toDiskSnapshot String
fp
    lift $ writeSnapshotMetadata fs ds bknd

  getInEnv :: CodecConfig (CardanoBlock StandardCrypto)
-> Format
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO (InEnv backend)
getInEnv CodecConfig (CardanoBlock StandardCrypto)
ccfg = \case
    Mem String
fp -> do
      (mtd, ds) <- String
-> SnapshotBackend
-> ExceptT
     (Error (CardanoBlock StandardCrypto)) IO (Maybe CRC, DiskSnapshot)
getMetadata String
fp SnapshotBackend
UTxOHDMemSnapshot
      (st, c) <- getState ccfg fp
      Monad.when
        ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds))
        ( throwError $
            WrongSlotDirectoryName
              (snapshotToDirName ds)
              ( withOrigin
                  ( error
                      "Impossible! the snapshot seems to be at Genesis but cardano-node would never create such an snapshot!"
                  )
                  id
                  $ pointSlot (getTip st)
              )
        )

      pure $
        InEnv
          st
          fp
          (\LedgerState (CardanoBlock StandardCrypto) EmptyMK
a ResourceRegistry IO
b -> YieldArgs IO Mem (LedgerState (CardanoBlock StandardCrypto))
-> SomeBackend YieldArgs
forall backend (c :: (* -> *) -> * -> LedgerStateKind -> *).
StreamingBackend
  IO backend (LedgerState (CardanoBlock StandardCrypto)) =>
c IO backend (LedgerState (CardanoBlock StandardCrypto))
-> SomeBackend c
SomeBackend (YieldArgs IO Mem (LedgerState (CardanoBlock StandardCrypto))
 -> SomeBackend YieldArgs)
-> IO
     (YieldArgs IO Mem (LedgerState (CardanoBlock StandardCrypto)))
-> IO (SomeBackend YieldArgs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> ResourceRegistry IO
-> IO
     (YieldArgs IO Mem (LedgerState (CardanoBlock StandardCrypto)))
mkInMemYieldArgs (String
fp String -> ShowS
F.</> String
"tables") LedgerState (CardanoBlock StandardCrypto) EmptyMK
a ResourceRegistry IO
b)
          ("InMemory@[" <> fp <> "]")
          c
          mtd
    LMDB String
fp -> do
      (mtd, ds) <- String
-> SnapshotBackend
-> ExceptT
     (Error (CardanoBlock StandardCrypto)) IO (Maybe CRC, DiskSnapshot)
getMetadata String
fp SnapshotBackend
UTxOHDLMDBSnapshot
      (st, c) <- getState ccfg fp
      Monad.when
        ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds))
        ( throwError $
            WrongSlotDirectoryName
              (snapshotToDirName ds)
              (withOrigin undefined id $ pointSlot (getTip st))
        )

      pure $
        InEnv
          st
          fp
          (\LedgerState (CardanoBlock StandardCrypto) EmptyMK
a ResourceRegistry IO
b -> YieldArgs IO LMDB (LedgerState (CardanoBlock StandardCrypto))
-> SomeBackend YieldArgs
forall backend (c :: (* -> *) -> * -> LedgerStateKind -> *).
StreamingBackend
  IO backend (LedgerState (CardanoBlock StandardCrypto)) =>
c IO backend (LedgerState (CardanoBlock StandardCrypto))
-> SomeBackend c
SomeBackend (YieldArgs IO LMDB (LedgerState (CardanoBlock StandardCrypto))
 -> SomeBackend YieldArgs)
-> IO
     (YieldArgs IO LMDB (LedgerState (CardanoBlock StandardCrypto)))
-> IO (SomeBackend YieldArgs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> LMDBLimits
-> LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> ResourceRegistry IO
-> IO
     (YieldArgs IO LMDB (LedgerState (CardanoBlock StandardCrypto)))
forall (l :: LedgerStateKind).
(HasCallStack, HasLedgerTables l,
 MemPackIdx l EmptyMK ~ l EmptyMK) =>
String
-> LMDBLimits
-> l EmptyMK
-> ResourceRegistry IO
-> IO (YieldArgs IO LMDB l)
V1.mkLMDBYieldArgs (String
fp String -> ShowS
F.</> String
"tables") LMDBLimits
defaultLMDBLimits LedgerState (CardanoBlock StandardCrypto) EmptyMK
a ResourceRegistry IO
b)
          ("LMDB@[" <> fp <> "]")
          c
          mtd
    LSM String
fp String
lsmDbPath -> do
      (mtd, ds) <- String
-> SnapshotBackend
-> ExceptT
     (Error (CardanoBlock StandardCrypto)) IO (Maybe CRC, DiskSnapshot)
getMetadata String
fp SnapshotBackend
UTxOHDLSMSnapshot
      (st, c) <- getState ccfg fp
      Monad.when
        ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds))
        ( throwError $
            WrongSlotDirectoryName
              (snapshotToDirName ds)
              (withOrigin undefined id $ pointSlot (getTip st))
        )

      pure $
        InEnv
          st
          fp
          ( \LedgerState (CardanoBlock StandardCrypto) EmptyMK
a ResourceRegistry IO
b ->
              YieldArgs IO LSM (LedgerState (CardanoBlock StandardCrypto))
-> SomeBackend YieldArgs
forall backend (c :: (* -> *) -> * -> LedgerStateKind -> *).
StreamingBackend
  IO backend (LedgerState (CardanoBlock StandardCrypto)) =>
c IO backend (LedgerState (CardanoBlock StandardCrypto))
-> SomeBackend c
SomeBackend (YieldArgs IO LSM (LedgerState (CardanoBlock StandardCrypto))
 -> SomeBackend YieldArgs)
-> IO
     (YieldArgs IO LSM (LedgerState (CardanoBlock StandardCrypto)))
-> IO (SomeBackend YieldArgs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> String
-> (String
    -> ResourceRegistry IO
    -> IO (ResourceKey IO, SomeHasFSAndBlockIO IO))
-> IO StdGen
-> LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> ResourceRegistry IO
-> IO
     (YieldArgs IO LSM (LedgerState (CardanoBlock StandardCrypto)))
forall (m :: * -> *) (l :: LedgerStateKind) a.
(IOLike m, HasLedgerTables l,
 IndexedMemPack (l EmptyMK) (TxOut l)) =>
String
-> String
-> (String -> ResourceRegistry m -> m (a, SomeHasFSAndBlockIO m))
-> m StdGen
-> l EmptyMK
-> ResourceRegistry m
-> m (YieldArgs m LSM l)
mkLSMYieldArgs String
lsmDbPath ([String] -> String
forall a. HasCallStack => [a] -> a
last ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String]
splitDirectories String
fp) String
-> ResourceRegistry IO
-> IO (ResourceKey IO, SomeHasFSAndBlockIO IO)
stdMkBlockIOFS IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen LedgerState (CardanoBlock StandardCrypto) EmptyMK
a ResourceRegistry IO
b
          )
          ("LSM@[" <> lsmDbPath <> "]")
          c
          mtd

  getOutEnv :: block mk
-> Format
-> ExceptT
     (Error (CardanoBlock StandardCrypto)) IO (OutEnv backend)
getOutEnv block mk
st = \case
    Mem String
fp -> do
      (_, ds) <- String
-> ExceptT
     (Error (CardanoBlock StandardCrypto))
     IO
     (SomeHasFS IO, DiskSnapshot)
toDiskSnapshot String
fp
      Monad.when
        ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds))
        ( throwError $
            WrongSlotDirectoryName
              (snapshotToDirName ds)
              (withOrigin undefined id $ pointSlot (getTip st))
        )
      pure $
        OutEnv
          fp
          (\LedgerState (CardanoBlock StandardCrypto) EmptyMK
a ResourceRegistry IO
b -> SinkArgs IO Mem (LedgerState (CardanoBlock StandardCrypto))
-> SomeBackend SinkArgs
forall backend (c :: (* -> *) -> * -> LedgerStateKind -> *).
StreamingBackend
  IO backend (LedgerState (CardanoBlock StandardCrypto)) =>
c IO backend (LedgerState (CardanoBlock StandardCrypto))
-> SomeBackend c
SomeBackend (SinkArgs IO Mem (LedgerState (CardanoBlock StandardCrypto))
 -> SomeBackend SinkArgs)
-> IO (SinkArgs IO Mem (LedgerState (CardanoBlock StandardCrypto)))
-> IO (SomeBackend SinkArgs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> ResourceRegistry IO
-> IO (SinkArgs IO Mem (LedgerState (CardanoBlock StandardCrypto)))
mkInMemSinkArgs (String
fp String -> ShowS
F.</> String
"tables") LedgerState (CardanoBlock StandardCrypto) EmptyMK
a ResourceRegistry IO
b)
          (Just "tables")
          (Nothing)
          ("InMemory@[" <> fp <> "]")
          UTxOHDMemSnapshot
    LMDB String
fp -> do
      (_, ds) <- String
-> ExceptT
     (Error (CardanoBlock StandardCrypto))
     IO
     (SomeHasFS IO, DiskSnapshot)
toDiskSnapshot String
fp
      Monad.when
        ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds))
        ( throwError $
            WrongSlotDirectoryName
              (snapshotToDirName ds)
              (withOrigin undefined id $ pointSlot (getTip st))
        )
      pure $
        OutEnv
          fp
          (\LedgerState (CardanoBlock StandardCrypto) EmptyMK
a ResourceRegistry IO
b -> SinkArgs IO LMDB (LedgerState (CardanoBlock StandardCrypto))
-> SomeBackend SinkArgs
forall backend (c :: (* -> *) -> * -> LedgerStateKind -> *).
StreamingBackend
  IO backend (LedgerState (CardanoBlock StandardCrypto)) =>
c IO backend (LedgerState (CardanoBlock StandardCrypto))
-> SomeBackend c
SomeBackend (SinkArgs IO LMDB (LedgerState (CardanoBlock StandardCrypto))
 -> SomeBackend SinkArgs)
-> IO
     (SinkArgs IO LMDB (LedgerState (CardanoBlock StandardCrypto)))
-> IO (SomeBackend SinkArgs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> LMDBLimits
-> LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> ResourceRegistry IO
-> IO
     (SinkArgs IO LMDB (LedgerState (CardanoBlock StandardCrypto)))
forall (l :: LedgerStateKind).
(HasCallStack, HasLedgerTables l,
 MemPackIdx l EmptyMK ~ l EmptyMK) =>
String
-> LMDBLimits
-> l EmptyMK
-> ResourceRegistry IO
-> IO (SinkArgs IO LMDB l)
V1.mkLMDBSinkArgs String
fp LMDBLimits
defaultLMDBLimits LedgerState (CardanoBlock StandardCrypto) EmptyMK
a ResourceRegistry IO
b)
          Nothing
          Nothing
          ("LMDB@[" <> fp <> "]")
          UTxOHDLMDBSnapshot
    LSM String
fp String
lsmDbPath -> do
      (_, ds) <- String
-> ExceptT
     (Error (CardanoBlock StandardCrypto))
     IO
     (SomeHasFS IO, DiskSnapshot)
toDiskSnapshot String
fp
      Monad.when
        ((unSlotNo <$> pointSlot (getTip st)) /= NotOrigin (dsNumber ds))
        ( throwError $
            WrongSlotDirectoryName
              (snapshotToDirName ds)
              (withOrigin undefined id $ pointSlot (getTip st))
        )
      pure $
        OutEnv
          fp
          ( \LedgerState (CardanoBlock StandardCrypto) EmptyMK
a ResourceRegistry IO
b ->
              SinkArgs IO LSM (LedgerState (CardanoBlock StandardCrypto))
-> SomeBackend SinkArgs
forall backend (c :: (* -> *) -> * -> LedgerStateKind -> *).
StreamingBackend
  IO backend (LedgerState (CardanoBlock StandardCrypto)) =>
c IO backend (LedgerState (CardanoBlock StandardCrypto))
-> SomeBackend c
SomeBackend (SinkArgs IO LSM (LedgerState (CardanoBlock StandardCrypto))
 -> SomeBackend SinkArgs)
-> IO (SinkArgs IO LSM (LedgerState (CardanoBlock StandardCrypto)))
-> IO (SomeBackend SinkArgs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> String
-> (String
    -> ResourceRegistry IO
    -> IO (ResourceKey IO, SomeHasFSAndBlockIO IO))
-> IO StdGen
-> LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> ResourceRegistry IO
-> IO (SinkArgs IO LSM (LedgerState (CardanoBlock StandardCrypto)))
forall (m :: * -> *) a (l :: LedgerStateKind).
IOLike m =>
String
-> String
-> (String -> ResourceRegistry m -> m (a, SomeHasFSAndBlockIO m))
-> m StdGen
-> l EmptyMK
-> ResourceRegistry m
-> m (SinkArgs m LSM l)
mkLSMSinkArgs String
lsmDbPath ([String] -> String
forall a. HasCallStack => [a] -> a
last ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String]
splitDirectories String
fp) String
-> ResourceRegistry IO
-> IO (ResourceKey IO, SomeHasFSAndBlockIO IO)
stdMkBlockIOFS IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen LedgerState (CardanoBlock StandardCrypto) EmptyMK
a ResourceRegistry IO
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 :: 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 LedgerState (CardanoBlock StandardCrypto) EmptyMK
st LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> ResourceRegistry IO -> IO (SomeBackend YieldArgs)
mYieldArgs LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> ResourceRegistry IO -> IO (SomeBackend SinkArgs)
mSinkArgs =
  IO (Either DeserialiseFailure (Maybe CRC, Maybe CRC))
-> ExceptT DeserialiseFailure IO (Maybe CRC, Maybe CRC)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either DeserialiseFailure (Maybe CRC, Maybe CRC))
 -> ExceptT DeserialiseFailure IO (Maybe CRC, Maybe CRC))
-> IO (Either DeserialiseFailure (Maybe CRC, Maybe CRC))
-> ExceptT DeserialiseFailure IO (Maybe CRC, Maybe CRC)
forall a b. (a -> b) -> a -> b
$
    (ResourceRegistry IO
 -> IO (Either DeserialiseFailure (Maybe CRC, Maybe CRC)))
-> IO (Either DeserialiseFailure (Maybe CRC, Maybe CRC))
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry ((ResourceRegistry IO
  -> IO (Either DeserialiseFailure (Maybe CRC, Maybe CRC)))
 -> IO (Either DeserialiseFailure (Maybe CRC, Maybe CRC)))
-> (ResourceRegistry IO
    -> IO (Either DeserialiseFailure (Maybe CRC, Maybe CRC)))
-> IO (Either DeserialiseFailure (Maybe CRC, Maybe CRC))
forall a b. (a -> b) -> a -> b
$ \ResourceRegistry IO
reg -> do
      (SomeBackend (yArgs :: YieldArgs IO backend1 l)) <- LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> ResourceRegistry IO -> IO (SomeBackend YieldArgs)
mYieldArgs LedgerState (CardanoBlock StandardCrypto) EmptyMK
st ResourceRegistry IO
reg
      (SomeBackend (sArgs :: SinkArgs IO backend2 l)) <- mSinkArgs st reg
      runExceptT $ yield (Proxy @backend1) yArgs st $ sink (Proxy @backend2) sArgs st

-- Helpers

-- UI
niceAnimatedProgressBar :: String -> String -> IO (Maybe (Async IO ()))
niceAnimatedProgressBar :: String -> String -> IO (Maybe (Async IO ()))
niceAnimatedProgressBar String
inMsg String
outMsg = do
  stdoutSupportsANSI <- Handle -> IO Bool
hNowSupportsANSI Handle
stdout
  if stdoutSupportsANSI
    then do
      putStrLn ""
      pb <-
        newProgressBar
          defStyle{stylePrefix = msg (T.pack inMsg), stylePostfix = msg (T.pack outMsg)}
          10
          (Progress 1 100 ())

      fmap Just $
        async $
          let loop = do
                DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.2
                ProgressBar () -> (Progress () -> Progress ()) -> IO ()
forall s. ProgressBar s -> (Progress s -> Progress s) -> IO ()
updateProgress ProgressBar ()
pb (\Progress ()
prg -> Progress ()
prg{progressDone = (progressDone prg + 4) `mod` 100})
           in Monad.forever loop
    else pure Nothing

putColored :: Color -> Bool -> String -> IO ()
putColored :: Color -> Bool -> String -> IO ()
putColored Color
c Bool
b String
s = do
  stdoutSupportsANSI <- Handle -> IO Bool
hNowSupportsANSI Handle
stdout
  Monad.when stdoutSupportsANSI $ setSGR [SetColor Foreground Vivid c]
  if b
    then
      putStrLn s
    else
      putStr s
  Monad.when stdoutSupportsANSI $ setSGR [Reset]
  hFlush stdout

askForConfirmation ::
  ExceptT (Error (CardanoBlock StandardCrypto)) IO a ->
  String ->
  ExceptT (Error (CardanoBlock StandardCrypto)) IO a
askForConfirmation :: forall a.
ExceptT (Error (CardanoBlock StandardCrypto)) IO a
-> String -> ExceptT (Error (CardanoBlock StandardCrypto)) IO a
askForConfirmation ExceptT (Error (CardanoBlock StandardCrypto)) IO a
act String
infoMsg = do
  IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Error (CardanoBlock StandardCrypto)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ())
-> IO () -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall a b. (a -> b) -> a -> b
$ Color -> Bool -> String -> IO ()
putColored Color
Yellow Bool
False (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"I'm going to " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
infoMsg String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
". Continue? (Y/n) "
  answer <- IO String
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO String
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Error (CardanoBlock StandardCrypto)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO String
 -> ExceptT (Error (CardanoBlock StandardCrypto)) IO String)
-> IO String
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO String
forall a b. (a -> b) -> a -> b
$ IO String
getLine
  case map toLower answer of
    String
"y" -> ExceptT (Error (CardanoBlock StandardCrypto)) IO a
act
    String
_ -> Error (CardanoBlock StandardCrypto)
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO a
forall a.
Error (CardanoBlock StandardCrypto)
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error (CardanoBlock StandardCrypto)
forall blk. Error blk
Cancelled

-- | Ask before deleting
wipePath :: FilePath -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
wipePath :: String -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
wipePath String
fp = do
  exists <- IO Bool -> ExceptT (Error (CardanoBlock StandardCrypto)) IO Bool
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Error (CardanoBlock StandardCrypto)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Bool -> ExceptT (Error (CardanoBlock StandardCrypto)) IO Bool)
-> IO Bool -> ExceptT (Error (CardanoBlock StandardCrypto)) IO Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
D.doesDirectoryExist String
fp
  ( if exists
      then flip askForConfirmation ("wipe the path " <> fp)
      else id
    )
    (lift $ D.removePathForcibly fp >> D.createDirectoryIfMissing True fp)

toDiskSnapshot ::
  FilePath -> ExceptT (Error (CardanoBlock StandardCrypto)) IO (SomeHasFS IO, DiskSnapshot)
toDiskSnapshot :: String
-> ExceptT
     (Error (CardanoBlock StandardCrypto))
     IO
     (SomeHasFS IO, DiskSnapshot)
toDiskSnapshot fp :: String
fp@(String -> (String, String)
F.splitFileName (String -> (String, String)) -> ShowS -> String -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
maybeRemoveTrailingSlash -> (String
snapPath, String
snapName)) =
  ExceptT
  (Error (CardanoBlock StandardCrypto))
  IO
  (SomeHasFS IO, DiskSnapshot)
-> (DiskSnapshot
    -> ExceptT
         (Error (CardanoBlock StandardCrypto))
         IO
         (SomeHasFS IO, DiskSnapshot))
-> Maybe DiskSnapshot
-> ExceptT
     (Error (CardanoBlock StandardCrypto))
     IO
     (SomeHasFS IO, DiskSnapshot)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    (Error (CardanoBlock StandardCrypto)
-> ExceptT
     (Error (CardanoBlock StandardCrypto))
     IO
     (SomeHasFS IO, DiskSnapshot)
forall a.
Error (CardanoBlock StandardCrypto)
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error (CardanoBlock StandardCrypto)
 -> ExceptT
      (Error (CardanoBlock StandardCrypto))
      IO
      (SomeHasFS IO, DiskSnapshot))
-> Error (CardanoBlock StandardCrypto)
-> ExceptT
     (Error (CardanoBlock StandardCrypto))
     IO
     (SomeHasFS IO, DiskSnapshot)
forall a b. (a -> b) -> a -> b
$ String -> Error (CardanoBlock StandardCrypto)
forall blk. String -> Error blk
BadDirectoryName String
fp)
    ((SomeHasFS IO, DiskSnapshot)
-> ExceptT
     (Error (CardanoBlock StandardCrypto))
     IO
     (SomeHasFS IO, DiskSnapshot)
forall a. a -> ExceptT (Error (CardanoBlock StandardCrypto)) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((SomeHasFS IO, DiskSnapshot)
 -> ExceptT
      (Error (CardanoBlock StandardCrypto))
      IO
      (SomeHasFS IO, DiskSnapshot))
-> (DiskSnapshot -> (SomeHasFS IO, DiskSnapshot))
-> DiskSnapshot
-> ExceptT
     (Error (CardanoBlock StandardCrypto))
     IO
     (SomeHasFS IO, DiskSnapshot)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> SomeHasFS IO
pathToHasFS String
snapPath,))
    (Maybe DiskSnapshot
 -> ExceptT
      (Error (CardanoBlock StandardCrypto))
      IO
      (SomeHasFS IO, DiskSnapshot))
-> Maybe DiskSnapshot
-> ExceptT
     (Error (CardanoBlock StandardCrypto))
     IO
     (SomeHasFS IO, DiskSnapshot)
forall a b. (a -> b) -> a -> b
$ String -> Maybe DiskSnapshot
snapshotFromPath String
snapName

-- | Given a filepath pointing to a snapshot (with or without a trailing slash), produce:
--
-- * A HasFS at the snapshot directory
pathToHasFS :: FilePath -> SomeHasFS IO
pathToHasFS :: String -> SomeHasFS IO
pathToHasFS (ShowS
maybeRemoveTrailingSlash -> String
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
$ String -> MountPoint
MountPoint String
path

maybeRemoveTrailingSlash :: String -> String
maybeRemoveTrailingSlash :: ShowS
maybeRemoveTrailingSlash String
s = case String -> Char
forall a. HasCallStack => [a] -> a
last String
s of
  Char
'/' -> ShowS
forall a. HasCallStack => [a] -> [a]
init String
s
  Char
'\\' -> ShowS
forall a. HasCallStack => [a] -> [a]
init String
s
  Char
_ -> String
s

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
    }