{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

-- | Convert snapshots among different formats. This is exposed in
-- @cardano-node@ as a subcommand and also via the @snapshot-converter@
-- executable.
module Ouroboros.Consensus.Cardano.SnapshotConversion
  ( SnapshotsDirectory (..)
  , LSMDatabaseFilePath (..)
  , Snapshot (..)
  , SnapshotsDirectoryWithFormat (..)
  , snapshotDirectory
  , StandaloneFormat (..)
  , convertSnapshot
  ) where

import Codec.Serialise
import Control.Monad (when)
import qualified Control.Monad as Monad
import Control.Monad.Except
import Control.Monad.Trans (lift)
import Control.ResourceRegistry
import Data.Bifunctor
import Data.Char (toLower)
import qualified Data.Text.Lazy as T
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Cardano.Block
import Ouroboros.Consensus.Cardano.Node ()
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.FS.API
import System.FS.CRC
import System.FS.IO
import qualified System.FilePath as F
import System.IO
import System.ProgressBar
import System.Random

data SnapshotsDirectory = SnapshotsDirectory {SnapshotsDirectory -> String
getSnapshotDir :: FilePath}

data LSMDatabaseFilePath = LSMDatabaseFilePath {LSMDatabaseFilePath -> String
getLSMDatabaseDir :: FilePath}

data StandaloneFormat
  = Mem
  | LMDB

data SnapshotsDirectoryWithFormat
  = StandaloneSnapshot SnapshotsDirectory StandaloneFormat
  | LSMSnapshot SnapshotsDirectory LSMDatabaseFilePath

data Snapshot = Snapshot
  { Snapshot -> SnapshotsDirectoryWithFormat
snapshotSnapShotDir :: SnapshotsDirectoryWithFormat
  , Snapshot -> DiskSnapshot
snapshotDiskSnapshot :: DiskSnapshot
  }

snapshotDirectory :: SnapshotsDirectoryWithFormat -> SnapshotsDirectory
snapshotDirectory :: SnapshotsDirectoryWithFormat -> SnapshotsDirectory
snapshotDirectory (StandaloneSnapshot SnapshotsDirectory
fp StandaloneFormat
_) = SnapshotsDirectory
fp
snapshotDirectory (LSMSnapshot SnapshotsDirectory
fp LSMDatabaseFilePath
_) = SnapshotsDirectory
fp

{-------------------------------------------------------------------------------
 Errors
-------------------------------------------------------------------------------}

data Error blk
  = SnapshotError (SnapshotFailure blk)
  | BadDirectoryName FilePath
  | WrongSlotDirectoryName FilePath SlotNo
  | SnapshotAtGenesis
  | 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 Error blk
SnapshotAtGenesis =
    String
"The provided snapshot is at Genesis. This should be impossible, the cardano-node will never create those!"
  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"

{-------------------------------------------------------------------------------
  Environments
-------------------------------------------------------------------------------}

data InEnv backend = InEnv
  { forall backend.
InEnv backend -> LedgerState (CardanoBlock StandardCrypto) EmptyMK
inState :: LedgerState (CardanoBlock StandardCrypto) EmptyMK
  -- ^ Ledger state (without tables) that will be used to index the snapshot.
  , forall backend.
InEnv backend -> ResourceRegistry IO -> IO (SomeBackend YieldArgs)
inStream ::
      ResourceRegistry IO ->
      IO (SomeBackend YieldArgs)
  -- ^ Yield arguments for producing a stream of TxOuts
  , forall backend. InEnv backend -> String
inProgressMsg :: String
  -- ^ A progress message (just for displaying)
  , forall backend. InEnv backend -> CRC
inCRC :: CRC
  -- ^ The CRC of the input @state@ file as read
  , forall backend. InEnv backend -> Maybe CRC
inSnapReadCRC :: Maybe CRC
  -- ^ The CRC of the input snapshot from the metadata file
  }

data OutEnv backend = OutEnv
  { forall backend.
OutEnv backend -> ResourceRegistry IO -> IO (SomeBackend SinkArgs)
outStream ::
      ResourceRegistry IO ->
      IO (SomeBackend SinkArgs)
  -- ^ Sink arguments for consuming a stream of TxOuts
  , forall backend. OutEnv backend -> Maybe String
outDeleteExtra :: Maybe FilePath
  -- ^ In case some other directory needs to be wiped out
  , forall backend. OutEnv backend -> String
outProgressMsg :: String
  -- ^ A progress message (just for displaying)
  , forall backend. OutEnv backend -> SnapshotBackend
outBackend :: SnapshotBackend
  -- ^ The backend used for the output snapshot, to write it in the metadata
  }

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

convertSnapshot ::
  Bool ->
  ProtocolInfo (CardanoBlock StandardCrypto) ->
  Snapshot ->
  Snapshot ->
  ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
convertSnapshot :: Bool
-> ProtocolInfo (CardanoBlock StandardCrypto)
-> Snapshot
-> Snapshot
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
convertSnapshot Bool
interactive (TopLevelConfig (CardanoBlock StandardCrypto)
-> CodecConfig (CardanoBlock StandardCrypto)
forall blk. TopLevelConfig blk -> CodecConfig blk
configCodec (TopLevelConfig (CardanoBlock StandardCrypto)
 -> CodecConfig (CardanoBlock StandardCrypto))
-> (ProtocolInfo (CardanoBlock StandardCrypto)
    -> TopLevelConfig (CardanoBlock StandardCrypto))
-> ProtocolInfo (CardanoBlock StandardCrypto)
-> CodecConfig (CardanoBlock StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolInfo (CardanoBlock StandardCrypto)
-> TopLevelConfig (CardanoBlock StandardCrypto)
forall b. ProtocolInfo b -> TopLevelConfig b
pInfoConfig -> CodecConfig (CardanoBlock StandardCrypto)
ccfg) Snapshot
from Snapshot
to = do
  InEnv{..} <- ExceptT
  (Error (CardanoBlock StandardCrypto)) IO (InEnv (ZonkAny 1))
forall backend.
ExceptT (Error (CardanoBlock StandardCrypto)) IO (InEnv backend)
getInEnv

  o@OutEnv{..} <- getOutEnv inState

  wipeOutputPaths o

  when interactive $ lift $ putStr "Copying state file..." >> hFlush stdout
  inStateFile <- lift $ unsafeToFilePath inHasFS (snapshotToStatePath inSnap)
  outStateFile <- lift $ unsafeToFilePath outHasFS (snapshotToStatePath outSnap)
  lift $ D.copyFile inStateFile outStateFile
  when interactive $ lift $ putColored Green True "Done"

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

  tid <-
    if interactive
      then lift $ niceAnimatedProgressBar inProgressMsg outProgressMsg
      else pure Nothing

  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
      Bool
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
interactive (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
$ 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
      Bool
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
interactive (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
$
        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

      Bool
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
interactive (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
$ 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
      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
$ SnapshotMetadata -> IO ()
putMetadata (SnapshotBackend -> CRC -> TablesCodecVersion -> SnapshotMetadata
SnapshotMetadata SnapshotBackend
outBackend CRC
crcOut TablesCodecVersion
TablesCodecVersion1)

      Bool
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
interactive (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
$ 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"
 where
  inSnap, outSnap :: DiskSnapshot
  inSnap :: DiskSnapshot
inSnap = Snapshot -> DiskSnapshot
snapshotDiskSnapshot Snapshot
from
  outSnap :: DiskSnapshot
outSnap = Snapshot -> DiskSnapshot
snapshotDiskSnapshot Snapshot
to

  inSnapDir, outSnapDir :: SnapshotsDirectory
  inSnapDir :: SnapshotsDirectory
inSnapDir = SnapshotsDirectoryWithFormat -> SnapshotsDirectory
snapshotDirectory (SnapshotsDirectoryWithFormat -> SnapshotsDirectory)
-> SnapshotsDirectoryWithFormat -> SnapshotsDirectory
forall a b. (a -> b) -> a -> b
$ Snapshot -> SnapshotsDirectoryWithFormat
snapshotSnapShotDir Snapshot
from
  outSnapDir :: SnapshotsDirectory
outSnapDir = SnapshotsDirectoryWithFormat -> SnapshotsDirectory
snapshotDirectory (SnapshotsDirectoryWithFormat -> SnapshotsDirectory)
-> SnapshotsDirectoryWithFormat -> SnapshotsDirectory
forall a b. (a -> b) -> a -> b
$ Snapshot -> SnapshotsDirectoryWithFormat
snapshotSnapShotDir Snapshot
to

  inHasFS, outHasFS :: HasFS IO HandleIO
  inHasFS :: HasFS IO HandleIO
inHasFS = MountPoint -> HasFS IO HandleIO
forall (m :: * -> *).
(MonadIO m, PrimState IO ~ PrimState m) =>
MountPoint -> HasFS m HandleIO
ioHasFS (String -> MountPoint
MountPoint (SnapshotsDirectory -> String
getSnapshotDir SnapshotsDirectory
inSnapDir))
  outHasFS :: HasFS IO HandleIO
outHasFS = MountPoint -> HasFS IO HandleIO
forall (m :: * -> *).
(MonadIO m, PrimState IO ~ PrimState m) =>
MountPoint -> HasFS m HandleIO
ioHasFS (String -> MountPoint
MountPoint (SnapshotsDirectory -> String
getSnapshotDir SnapshotsDirectory
outSnapDir))

  inSomeHasFS, outSomeHasFS :: SomeHasFS IO
  inSomeHasFS :: SomeHasFS IO
inSomeHasFS = HasFS IO HandleIO -> SomeHasFS IO
forall h (m :: * -> *). Eq h => HasFS m h -> SomeHasFS m
SomeHasFS HasFS IO HandleIO
inHasFS
  outSomeHasFS :: SomeHasFS IO
outSomeHasFS = HasFS IO HandleIO -> SomeHasFS IO
forall h (m :: * -> *). Eq h => HasFS m h -> SomeHasFS m
SomeHasFS HasFS IO HandleIO
outHasFS

  wipeOutputPaths :: OutEnv (ZonkAny 0)
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
wipeOutputPaths OutEnv{String
Maybe String
SnapshotBackend
ResourceRegistry IO -> IO (SomeBackend SinkArgs)
outStream :: forall backend.
OutEnv backend -> ResourceRegistry IO -> IO (SomeBackend SinkArgs)
outDeleteExtra :: forall backend. OutEnv backend -> Maybe String
outProgressMsg :: forall backend. OutEnv backend -> String
outBackend :: forall backend. OutEnv backend -> SnapshotBackend
outStream :: ResourceRegistry IO -> IO (SomeBackend SinkArgs)
outDeleteExtra :: Maybe String
outProgressMsg :: String
outBackend :: SnapshotBackend
..} = do
    Bool
-> String -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
wipePath Bool
interactive (SnapshotsDirectory -> String
getSnapshotDir SnapshotsDirectory
outSnapDir String -> ShowS
F.</> DiskSnapshot -> String
snapshotToDirName DiskSnapshot
outSnap)
    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 ())
      (Bool
-> String -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
wipePath Bool
interactive)
      Maybe String
outDeleteExtra

  getState ::
    DiskSnapshot ->
    ExceptT
      (Error (CardanoBlock StandardCrypto))
      IO
      (LedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
  getState :: DiskSnapshot
-> ExceptT
     (Error (CardanoBlock StandardCrypto))
     IO
     (LedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
getState DiskSnapshot
ds = do
    eState <- IO
  (Either
     ReadIncrementalErr
     (ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC))
-> ExceptT
     (Error (CardanoBlock StandardCrypto))
     IO
     (Either
        ReadIncrementalErr
        (ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC))
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
   (Either
      ReadIncrementalErr
      (ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC))
 -> ExceptT
      (Error (CardanoBlock StandardCrypto))
      IO
      (Either
         ReadIncrementalErr
         (ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)))
-> IO
     (Either
        ReadIncrementalErr
        (ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC))
-> ExceptT
     (Error (CardanoBlock StandardCrypto))
     IO
     (Either
        ReadIncrementalErr
        (ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC))
forall a b. (a -> b) -> a -> b
$ do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
interactive (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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
<> DiskSnapshot -> String
snapshotToDirName DiskSnapshot
ds String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"..."
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
interactive (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hFlush Handle
stdout
      ExceptT
  ReadIncrementalErr
  IO
  (ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
-> IO
     (Either
        ReadIncrementalErr
        (ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
        (SomeHasFS IO
-> (forall s.
    Decoder s (ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK))
-> (forall s. Decoder s (HeaderHash (CardanoBlock StandardCrypto)))
-> FsPath
-> ExceptT
     ReadIncrementalErr
     IO
     (ExtLedgerState (CardanoBlock StandardCrypto) 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
inSomeHasFS (CodecConfig (CardanoBlock StandardCrypto)
-> forall s.
   Decoder s (ExtLedgerState (CardanoBlock StandardCrypto) 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 (CardanoBlock StandardCrypto)
ccfg) Decoder s (HeaderHash (CardanoBlock StandardCrypto))
Decoder
  s (OneEraHash (ByronBlock : CardanoShelleyEras StandardCrypto))
forall s. Decoder s (HeaderHash (CardanoBlock StandardCrypto))
forall s.
Decoder
  s (OneEraHash (ByronBlock : CardanoShelleyEras StandardCrypto))
forall a s. Serialise a => Decoder s a
decode (DiskSnapshot -> FsPath
snapshotToStatePath DiskSnapshot
ds))
    case eState of
      Left ReadIncrementalErr
err ->
        Error (CardanoBlock StandardCrypto)
-> ExceptT
     (Error (CardanoBlock StandardCrypto))
     IO
     (LedgerState (CardanoBlock StandardCrypto) EmptyMK, 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
      (LedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC))
-> (ReadIncrementalErr -> Error (CardanoBlock StandardCrypto))
-> ReadIncrementalErr
-> ExceptT
     (Error (CardanoBlock StandardCrypto))
     IO
     (LedgerState (CardanoBlock StandardCrypto) 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
 -> ExceptT
      (Error (CardanoBlock StandardCrypto))
      IO
      (LedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC))
-> ReadIncrementalErr
-> ExceptT
     (Error (CardanoBlock StandardCrypto))
     IO
     (LedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
forall a b. (a -> b) -> a -> b
$
          ReadIncrementalErr
err
      Right (ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
st -> IO (LedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
-> ExceptT
     (Error (CardanoBlock StandardCrypto))
     IO
     (LedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
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 (LedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
 -> ExceptT
      (Error (CardanoBlock StandardCrypto))
      IO
      (LedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC))
-> IO (LedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
-> ExceptT
     (Error (CardanoBlock StandardCrypto))
     IO
     (LedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
forall a b. (a -> b) -> a -> b
$ do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
interactive (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Color -> Bool -> String -> IO ()
putColored Color
Green Bool
True String
" Done"
        (LedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
-> IO (LedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((LedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
 -> IO (LedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC))
-> ((ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
    -> (LedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC))
-> (ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
-> IO (LedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK
 -> LedgerState (CardanoBlock StandardCrypto) EmptyMK)
-> (ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
-> (LedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK
-> LedgerState (CardanoBlock StandardCrypto) EmptyMK
forall blk (mk :: * -> * -> *).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState ((ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
 -> IO (LedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC))
-> (ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
-> IO (LedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
forall a b. (a -> b) -> a -> b
$ (ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK, CRC)
st

  -- Get the CRC of the input snapshot if the backend matches the expected one
  getMetadata ::
    DiskSnapshot ->
    SnapshotBackend ->
    ExceptT (Error (CardanoBlock StandardCrypto)) IO (Maybe CRC)
  getMetadata :: DiskSnapshot
-> SnapshotBackend
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO (Maybe CRC)
getMetadata DiskSnapshot
ds SnapshotBackend
expectedBackend = do
    mtd <-
      IO (Either MetadataErr SnapshotMetadata)
-> ExceptT
     (Error (CardanoBlock StandardCrypto))
     IO
     (Either MetadataErr SnapshotMetadata)
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 (Either MetadataErr SnapshotMetadata)
 -> ExceptT
      (Error (CardanoBlock StandardCrypto))
      IO
      (Either MetadataErr SnapshotMetadata))
-> IO (Either MetadataErr SnapshotMetadata)
-> ExceptT
     (Error (CardanoBlock StandardCrypto))
     IO
     (Either MetadataErr SnapshotMetadata)
forall a b. (a -> b) -> a -> b
$
        ExceptT MetadataErr IO SnapshotMetadata
-> IO (Either MetadataErr SnapshotMetadata)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT MetadataErr IO SnapshotMetadata
 -> IO (Either MetadataErr SnapshotMetadata))
-> ExceptT MetadataErr IO SnapshotMetadata
-> IO (Either MetadataErr SnapshotMetadata)
forall a b. (a -> b) -> a -> b
$
          SomeHasFS IO
-> DiskSnapshot -> ExceptT MetadataErr IO SnapshotMetadata
forall (m :: * -> *).
IOLike m =>
SomeHasFS m
-> DiskSnapshot -> ExceptT MetadataErr m SnapshotMetadata
loadSnapshotMetadata SomeHasFS IO
inSomeHasFS DiskSnapshot
ds
    case mtd of
      Left 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
      Left (MetadataInvalid String
why) -> 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
why
      Left MetadataErr
MetadataBackendMismatch -> String
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO (Maybe CRC)
forall a. HasCallStack => String -> a
error String
"impossible"
      Right SnapshotMetadata
mtd' ->
        if SnapshotBackend
expectedBackend 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
expectedBackend (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'

  -- Write the snapshot metadata for the output snapshot
  putMetadata :: SnapshotMetadata -> IO ()
  putMetadata :: SnapshotMetadata -> IO ()
putMetadata SnapshotMetadata
bknd =
    SomeHasFS IO -> DiskSnapshot -> SnapshotMetadata -> IO ()
forall (m :: * -> *).
MonadThrow m =>
SomeHasFS m -> DiskSnapshot -> SnapshotMetadata -> m ()
writeSnapshotMetadata SomeHasFS IO
outSomeHasFS DiskSnapshot
outSnap SnapshotMetadata
bknd

  checkSnapSlot ::
    LedgerState (CardanoBlock StandardCrypto) EmptyMK ->
    DiskSnapshot ->
    ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
  checkSnapSlot :: LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> DiskSnapshot
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
checkSnapSlot LedgerState (CardanoBlock StandardCrypto) EmptyMK
st DiskSnapshot
ds =
    ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
-> (SlotNo -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ())
-> WithOrigin SlotNo
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall b t. b -> (t -> b) -> WithOrigin t -> b
withOrigin
      (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)
forall blk. Error blk
SnapshotAtGenesis)
      ( \SlotNo
t ->
          Bool
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.when (SlotNo -> Word64
unSlotNo SlotNo
t Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= DiskSnapshot -> Word64
dsNumber DiskSnapshot
ds) (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
$
              String -> SlotNo -> Error (CardanoBlock StandardCrypto)
forall blk. String -> SlotNo -> Error blk
WrongSlotDirectoryName (DiskSnapshot -> String
snapshotToDirName DiskSnapshot
ds) SlotNo
t
      )
      (Point (LedgerState (CardanoBlock StandardCrypto))
-> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot (Point (LedgerState (CardanoBlock StandardCrypto))
 -> WithOrigin SlotNo)
-> Point (LedgerState (CardanoBlock StandardCrypto))
-> WithOrigin SlotNo
forall a b. (a -> b) -> a -> b
$ LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> Point (LedgerState (CardanoBlock StandardCrypto))
forall (mk :: * -> * -> *).
LedgerState (CardanoBlock StandardCrypto) mk
-> Point (LedgerState (CardanoBlock StandardCrypto))
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
GetTip l =>
l mk -> Point l
getTip LedgerState (CardanoBlock StandardCrypto) EmptyMK
st)

  -- Produce an InEnv from the given arguments
  getInEnv :: ExceptT (Error (CardanoBlock StandardCrypto)) IO (InEnv backend)
  getInEnv :: forall backend.
ExceptT (Error (CardanoBlock StandardCrypto)) IO (InEnv backend)
getInEnv = case Snapshot
from of
    Snapshot (StandaloneSnapshot SnapshotsDirectory
_ StandaloneFormat
Mem) DiskSnapshot
_ -> do
      metadataCrc <- DiskSnapshot
-> SnapshotBackend
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO (Maybe CRC)
getMetadata DiskSnapshot
inSnap SnapshotBackend
UTxOHDMemSnapshot
      (st, c) <- getState inSnap
      checkSnapSlot st inSnap
      pure $
        InEnv
          st
          (pure . SomeBackend . mkInMemYieldArgs inSomeHasFS inSnap st)
          ("InMemory@[" <> snapshotToDirName inSnap <> "]")
          c
          metadataCrc
    Snapshot (StandaloneSnapshot SnapshotsDirectory
_ StandaloneFormat
LMDB) DiskSnapshot
_ -> do
      metadataCrc <- DiskSnapshot
-> SnapshotBackend
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO (Maybe CRC)
getMetadata DiskSnapshot
inSnap SnapshotBackend
UTxOHDLMDBSnapshot
      (st, c) <- getState inSnap
      checkSnapSlot st inSnap
      pure $
        InEnv
          st
          (\ResourceRegistry IO
reg -> 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
<$> SomeHasFS IO
-> DiskSnapshot
-> 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) =>
SomeHasFS IO
-> DiskSnapshot
-> LMDBLimits
-> l EmptyMK
-> ResourceRegistry IO
-> IO (YieldArgs IO LMDB l)
V1.mkLMDBYieldArgs SomeHasFS IO
inSomeHasFS DiskSnapshot
inSnap LMDBLimits
defaultLMDBLimits LedgerState (CardanoBlock StandardCrypto) EmptyMK
st ResourceRegistry IO
reg)
          ("LMDB@[" <> snapshotToDirName inSnap <> "]")
          c
          metadataCrc
    Snapshot (LSMSnapshot SnapshotsDirectory
_ (LSMDatabaseFilePath -> String
getLSMDatabaseDir -> String
lsmDbPath)) DiskSnapshot
_ -> do
      metadataCrc <- DiskSnapshot
-> SnapshotBackend
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO (Maybe CRC)
getMetadata DiskSnapshot
inSnap SnapshotBackend
UTxOHDLSMSnapshot
      (st, c) <- getState inSnap
      checkSnapSlot st inSnap
      pure $
        InEnv
          st
          ( \ResourceRegistry IO
reg ->
              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
-> DiskSnapshot
-> (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
-> DiskSnapshot
-> (String -> ResourceRegistry m -> m (a, SomeHasFSAndBlockIO m))
-> m StdGen
-> l EmptyMK
-> ResourceRegistry m
-> m (YieldArgs m LSM l)
mkLSMYieldArgs String
lsmDbPath DiskSnapshot
inSnap String
-> ResourceRegistry IO
-> IO (ResourceKey IO, SomeHasFSAndBlockIO IO)
stdMkBlockIOFS IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen LedgerState (CardanoBlock StandardCrypto) EmptyMK
st ResourceRegistry IO
reg
          )
          ("LSM@[" <> lsmDbPath <> "]")
          c
          metadataCrc

  -- Produce an OutEnv from the given arguments
  getOutEnv ::
    LedgerState (CardanoBlock StandardCrypto) EmptyMK ->
    ExceptT (Error (CardanoBlock StandardCrypto)) IO (OutEnv backend)
  getOutEnv :: forall backend.
LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> ExceptT
     (Error (CardanoBlock StandardCrypto)) IO (OutEnv backend)
getOutEnv LedgerState (CardanoBlock StandardCrypto) EmptyMK
st = case Snapshot
to of
    Snapshot (StandaloneSnapshot SnapshotsDirectory
_ StandaloneFormat
Mem) DiskSnapshot
_ -> do
      LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> DiskSnapshot
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
checkSnapSlot LedgerState (CardanoBlock StandardCrypto) EmptyMK
st DiskSnapshot
outSnap
      OutEnv backend
-> ExceptT
     (Error (CardanoBlock StandardCrypto)) IO (OutEnv backend)
forall a. a -> ExceptT (Error (CardanoBlock StandardCrypto)) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OutEnv backend
 -> ExceptT
      (Error (CardanoBlock StandardCrypto)) IO (OutEnv backend))
-> OutEnv backend
-> ExceptT
     (Error (CardanoBlock StandardCrypto)) IO (OutEnv backend)
forall a b. (a -> b) -> a -> b
$
        (ResourceRegistry IO -> IO (SomeBackend SinkArgs))
-> Maybe String -> String -> SnapshotBackend -> OutEnv backend
forall backend.
(ResourceRegistry IO -> IO (SomeBackend SinkArgs))
-> Maybe String -> String -> SnapshotBackend -> OutEnv backend
OutEnv
          (SomeBackend SinkArgs -> IO (SomeBackend SinkArgs)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeBackend SinkArgs -> IO (SomeBackend SinkArgs))
-> (ResourceRegistry IO -> SomeBackend SinkArgs)
-> ResourceRegistry IO
-> IO (SomeBackend SinkArgs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
-> (ResourceRegistry IO
    -> SinkArgs IO Mem (LedgerState (CardanoBlock StandardCrypto)))
-> ResourceRegistry IO
-> SomeBackend SinkArgs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeHasFS IO
-> DiskSnapshot
-> LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> ResourceRegistry IO
-> SinkArgs IO Mem (LedgerState (CardanoBlock StandardCrypto))
mkInMemSinkArgs SomeHasFS IO
outSomeHasFS DiskSnapshot
outSnap LedgerState (CardanoBlock StandardCrypto) EmptyMK
st)
          Maybe String
forall a. Maybe a
Nothing
          (String
"InMemory@[" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> DiskSnapshot -> String
snapshotToDirName DiskSnapshot
outSnap String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"]")
          SnapshotBackend
UTxOHDMemSnapshot
    Snapshot (StandaloneSnapshot SnapshotsDirectory
_ StandaloneFormat
LMDB) DiskSnapshot
_ -> do
      LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> DiskSnapshot
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
checkSnapSlot LedgerState (CardanoBlock StandardCrypto) EmptyMK
st DiskSnapshot
outSnap
      OutEnv backend
-> ExceptT
     (Error (CardanoBlock StandardCrypto)) IO (OutEnv backend)
forall a. a -> ExceptT (Error (CardanoBlock StandardCrypto)) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OutEnv backend
 -> ExceptT
      (Error (CardanoBlock StandardCrypto)) IO (OutEnv backend))
-> OutEnv backend
-> ExceptT
     (Error (CardanoBlock StandardCrypto)) IO (OutEnv backend)
forall a b. (a -> b) -> a -> b
$
        (ResourceRegistry IO -> IO (SomeBackend SinkArgs))
-> Maybe String -> String -> SnapshotBackend -> OutEnv backend
forall backend.
(ResourceRegistry IO -> IO (SomeBackend SinkArgs))
-> Maybe String -> String -> SnapshotBackend -> OutEnv backend
OutEnv
          (\ResourceRegistry IO
reg -> 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
<$> SomeHasFS IO
-> DiskSnapshot
-> 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) =>
SomeHasFS IO
-> DiskSnapshot
-> LMDBLimits
-> l EmptyMK
-> ResourceRegistry IO
-> IO (SinkArgs IO LMDB l)
V1.mkLMDBSinkArgs SomeHasFS IO
outSomeHasFS DiskSnapshot
outSnap LMDBLimits
defaultLMDBLimits LedgerState (CardanoBlock StandardCrypto) EmptyMK
st ResourceRegistry IO
reg)
          Maybe String
forall a. Maybe a
Nothing
          (String
"LMDB@[" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> DiskSnapshot -> String
snapshotToDirName DiskSnapshot
outSnap String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"]")
          SnapshotBackend
UTxOHDLMDBSnapshot
    Snapshot (LSMSnapshot SnapshotsDirectory
_ (String -> (String, String)
F.splitFileName (String -> (String, String))
-> (LSMDatabaseFilePath -> String)
-> LSMDatabaseFilePath
-> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LSMDatabaseFilePath -> String
getLSMDatabaseDir -> (String
lsmDbParentPath, String
lsmDbPath))) DiskSnapshot
_ -> do
      LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> DiskSnapshot
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
checkSnapSlot LedgerState (CardanoBlock StandardCrypto) EmptyMK
st DiskSnapshot
outSnap
      OutEnv backend
-> ExceptT
     (Error (CardanoBlock StandardCrypto)) IO (OutEnv backend)
forall a. a -> ExceptT (Error (CardanoBlock StandardCrypto)) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OutEnv backend
 -> ExceptT
      (Error (CardanoBlock StandardCrypto)) IO (OutEnv backend))
-> OutEnv backend
-> ExceptT
     (Error (CardanoBlock StandardCrypto)) IO (OutEnv backend)
forall a b. (a -> b) -> a -> b
$
        (ResourceRegistry IO -> IO (SomeBackend SinkArgs))
-> Maybe String -> String -> SnapshotBackend -> OutEnv backend
forall backend.
(ResourceRegistry IO -> IO (SomeBackend SinkArgs))
-> Maybe String -> String -> SnapshotBackend -> OutEnv backend
OutEnv
          ( \ResourceRegistry IO
reg ->
              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
-> FsPath
-> DiskSnapshot
-> SomeHasFS IO
-> (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
-> FsPath
-> DiskSnapshot
-> SomeHasFS m
-> (String -> ResourceRegistry m -> m (a, SomeHasFSAndBlockIO m))
-> m StdGen
-> l EmptyMK
-> ResourceRegistry m
-> m (SinkArgs m LSM l)
mkLSMSinkArgs
                  String
lsmDbParentPath
                  ([String] -> FsPath
mkFsPath [String
lsmDbPath])
                  DiskSnapshot
outSnap
                  SomeHasFS IO
outSomeHasFS
                  String
-> ResourceRegistry IO
-> IO (ResourceKey IO, SomeHasFSAndBlockIO IO)
stdMkBlockIOFS
                  IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
                  LedgerState (CardanoBlock StandardCrypto) EmptyMK
st
                  ResourceRegistry IO
reg
          )
          (String -> Maybe String
forall a. a -> Maybe a
Just String
lsmDbPath)
          (String
"LSM@[" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
lsmDbPath String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"]")
          SnapshotBackend
UTxOHDLSMSnapshot

  stream ::
    LedgerState (CardanoBlock StandardCrypto) EmptyMK ->
    ( ResourceRegistry IO ->
      IO (SomeBackend YieldArgs)
    ) ->
    ( ResourceRegistry IO ->
      IO (SomeBackend SinkArgs)
    ) ->
    ExceptT DeserialiseFailure IO (Maybe CRC, Maybe CRC)
  stream :: LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> (ResourceRegistry IO -> IO (SomeBackend YieldArgs))
-> (ResourceRegistry IO -> IO (SomeBackend SinkArgs))
-> ExceptT DeserialiseFailure IO (Maybe CRC, Maybe CRC)
stream LedgerState (CardanoBlock StandardCrypto) EmptyMK
st ResourceRegistry IO -> IO (SomeBackend YieldArgs)
mYieldArgs 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)) <- ResourceRegistry IO -> IO (SomeBackend YieldArgs)
mYieldArgs ResourceRegistry IO
reg
        (SomeBackend (sArgs :: SinkArgs IO backend2 l)) <- mSinkArgs reg
        runExceptT $ yield (Proxy @backend1) yArgs st $ sink (Proxy @backend2) sArgs st

{-------------------------------------------------------------------------------
  User interaction
-------------------------------------------------------------------------------}

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 ::
  Bool ->
  ExceptT (Error (CardanoBlock StandardCrypto)) IO a ->
  String ->
  ExceptT (Error (CardanoBlock StandardCrypto)) IO a
askForConfirmation :: forall a.
Bool
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO a
-> String
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO a
askForConfirmation Bool
False ExceptT (Error (CardanoBlock StandardCrypto)) IO a
act String
_ = ExceptT (Error (CardanoBlock StandardCrypto)) IO a
act
askForConfirmation Bool
True 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 :: Bool -> FilePath -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
wipePath :: Bool
-> String -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
wipePath Bool
interactive 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 interactive) ("wipe the path " <> fp)
      else id
    )
    (lift $ D.removePathForcibly fp >> D.createDirectoryIfMissing True fp)

{-------------------------------------------------------------------------------
  Helpers
-------------------------------------------------------------------------------}

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
    }