{-# 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 (..)
  , ExportedSnapshotPath (..)
  , 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 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.Abstract
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Node.ProtocolInfo
import Ouroboros.Consensus.Storage.LedgerDB.API
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
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 -> [Char]
getSnapshotDir :: FilePath}

-- | The directory holding a standalone (exported) LSM snapshot, i.e. the LSM
-- ledger tables exported out of a session via @lsm-tree@'s @exportSnapshot@.
--
-- This is paired with a 'SnapshotsDirectory' that holds the @state@/@meta@
-- files, just like the parts of an LSM snapshot inside a running node are split
-- between the ChainDB @ledger@ directory and the LSM session directory.
data ExportedSnapshotPath = ExportedSnapshotPath {ExportedSnapshotPath -> [Char]
getExportedSnapshotPath :: FilePath}

data StandaloneFormat
  = Mem

data SnapshotsDirectoryWithFormat
  = StandaloneSnapshot SnapshotsDirectory StandaloneFormat
  | -- | A standalone (exported) LSM snapshot. Conversions never operate on a
    -- live LSM database; they only ever read from or write to exported
    -- snapshots (see 'ExportedSnapshotPath').
    ExportedLSMSnapshot SnapshotsDirectory ExportedSnapshotPath

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 (ExportedLSMSnapshot SnapshotsDirectory
fp ExportedSnapshotPath
_) = 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 -> [Char])
-> (Error blk -> Bool)
-> Exception (Error blk)
SomeException -> Maybe (Error blk)
Error blk -> Bool
Error blk -> [Char]
Error blk -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> [Char])
-> (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 -> [Char]
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 -> [Char]
displayException :: Error blk -> [Char]
$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 -> [Char]
show Error blk
SnapshotAtGenesis =
    [Char]
"The provided snapshot is at Genesis. This should be impossible, the cardano-node will never create those!"
  show (SnapshotError SnapshotFailure blk
err) =
    [Char]
"Couldn't deserialize the snapshot. Are you running the same node version that created the snapshot? "
      [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> SnapshotFailure blk -> [Char]
forall a. Show a => a -> [Char]
show SnapshotFailure blk
err
  show (BadDirectoryName [Char]
fp) =
    [[Char]] -> [Char]
forall a. Monoid a => [a] -> a
mconcat
      [ [Char]
"Filepath "
      , [Char]
fp
      , [Char]
" is not an snapshot. The last fragment on the path should be"
      , [Char]
" named after the slot number of the state it contains and an"
      , [Char]
" optional suffix, such as `163470034` or `163470034_my-suffix`."
      ]
  show (InvalidMetadata [Char]
s) = [Char]
"Metadata is invalid: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
s
  show (BackendMismatch SnapshotBackend
b1 SnapshotBackend
b2) =
    [[Char]] -> [Char]
forall a. Monoid a => [a] -> a
mconcat
      [ [Char]
"Mismatched backend in snapshot. Reading as "
      , SnapshotBackend -> [Char]
forall a. Show a => a -> [Char]
show SnapshotBackend
b1
      , [Char]
" but snapshot is "
      , SnapshotBackend -> [Char]
forall a. Show a => a -> [Char]
show SnapshotBackend
b2
      ]
  show (WrongSlotDirectoryName [Char]
fp SlotNo
sl) =
    [[Char]] -> [Char]
forall a. Monoid a => [a] -> a
mconcat
      [ [Char]
"The name of the snapshot (\""
      , [Char]
fp
      , [Char]
"\") does not correspond to the slot number of the state ("
      , (Word64 -> [Char]
forall a. Show a => a -> [Char]
show (Word64 -> [Char]) -> (SlotNo -> Word64) -> SlotNo -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> Word64
unSlotNo (SlotNo -> [Char]) -> SlotNo -> [Char]
forall a b. (a -> b) -> a -> b
$ SlotNo
sl)
      , [Char]
")."
      ]
  show (CRCMismatch CRC
c1 CRC
c2) =
    [[Char]] -> [Char]
forall a. Monoid a => [a] -> a
mconcat
      [ [Char]
"The input snapshot seems corrupted. Metadata has CRC "
      , CRC -> [Char]
forall a. Show a => a -> [Char]
show CRC
c1
      , [Char]
" but reading it gives CRC "
      , CRC -> [Char]
forall a. Show a => a -> [Char]
show CRC
c2
      ]
  show (ReadTablesError DeserialiseFailure
df) =
    [[Char]] -> [Char]
forall a. Monoid a => [a] -> a
mconcat
      [[Char]
"Error when reading entries in the UTxO tables: ", DeserialiseFailure -> [Char]
forall a. Show a => a -> [Char]
show DeserialiseFailure
df]
  show Error blk
Cancelled = [Char]
"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 -> IO (SomeBackend YieldArgs)
inStream :: IO (SomeBackend YieldArgs)
  -- ^ Yield arguments for producing a stream of TxOuts
  , forall backend. InEnv backend -> [Char]
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 -> IO (SomeBackend SinkArgs)
outStream :: IO (SomeBackend SinkArgs)
  -- ^ Sink arguments for consuming a stream of TxOuts
  , forall backend. OutEnv backend -> [Char]
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

instance NoThunks (SomeBackend c) where
  wNoThunks :: [[Char]] -> SomeBackend c -> IO (Maybe ThunkInfo)
wNoThunks [[Char]]
_ (SomeBackend c IO backend LedgerState (CardanoBlock StandardCrypto)
_) = Maybe ThunkInfo -> IO (Maybe ThunkInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ThunkInfo
forall a. Maybe a
Nothing
  showTypeOf :: Proxy (SomeBackend c) -> [Char]
showTypeOf Proxy (SomeBackend c)
_ = [Char]
"SomeBackend"

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 0))
forall backend.
ExceptT (Error (CardanoBlock StandardCrypto)) IO (InEnv backend)
getInEnv

  OutEnv{..} <- getOutEnv inState

  wipePath interactive (getSnapshotDir outSnapDir F.</> snapshotToDirName outSnap)

  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 ())
Maybe (Async IO ())
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 -> [Char] -> IO ()
putColored Color
Green Bool
True [Char]
"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 -> [Char] -> IO ()
putColored Color
Yellow Bool
True [Char]
"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
$ [Char] -> IO ()
putStr [Char]
"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 -> [Char] -> IO ()
putColored Color
Green Bool
True [Char]
"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 ([Char] -> MountPoint
MountPoint (SnapshotsDirectory -> [Char]
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 ([Char] -> MountPoint
MountPoint (SnapshotsDirectory -> [Char]
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

  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
$ [Char] -> IO ()
putStr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Reading ledger state from " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> DiskSnapshot -> [Char]
snapshotToDirName DiskSnapshot
ds [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"..."
      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), DecodeDisk blk (PerasState 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 -> [Char] -> IO ()
putColored Color
Green Bool
True [Char]
" 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 :: MapKind) 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 :: MapKind).
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 [Char]
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
$ [Char] -> Error (CardanoBlock StandardCrypto)
forall blk. [Char] -> Error blk
InvalidMetadata [Char]
why
      Left MetadataErr
MetadataBackendMismatch -> [Char]
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO (Maybe CRC)
forall a. HasCallStack => [Char] -> a
error [Char]
"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
$
              [Char] -> SlotNo -> Error (CardanoBlock StandardCrypto)
forall blk. [Char] -> SlotNo -> Error blk
WrongSlotDirectoryName (DiskSnapshot -> [Char]
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 :: MapKind).
LedgerState (CardanoBlock StandardCrypto) mk
-> Point (LedgerState (CardanoBlock StandardCrypto))
forall (l :: MapKind -> *) (mk :: MapKind).
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 (ExportedLSMSnapshot SnapshotsDirectory
_ (ExportedSnapshotPath -> [Char]
getExportedSnapshotPath -> [Char]
exportDir)) 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
          ( SomeBackend
              <$> mkExportedLSMYieldArgs exportDir inSnap stdMkBlockIOFS (SomeHasFS . ioHasFS . MountPoint) newStdGen
          )
          ("LSM (exported)@[" <> exportDir <> "]")
          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
$
        IO (SomeBackend SinkArgs)
-> [Char] -> SnapshotBackend -> OutEnv backend
forall backend.
IO (SomeBackend SinkArgs)
-> [Char] -> 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))
-> SomeBackend SinkArgs -> IO (SomeBackend SinkArgs)
forall a b. (a -> b) -> a -> b
$ SinkArgs IO Mem LedgerState (CardanoBlock StandardCrypto)
-> SomeBackend SinkArgs
forall backend
       (c :: (* -> *) -> * -> (* -> MapKind -> *) -> * -> *).
StreamingBackend
  IO backend LedgerState (CardanoBlock StandardCrypto) =>
c IO backend LedgerState (CardanoBlock StandardCrypto)
-> SomeBackend c
SomeBackend (SinkArgs IO Mem LedgerState (CardanoBlock StandardCrypto)
 -> SomeBackend SinkArgs)
-> SinkArgs IO Mem LedgerState (CardanoBlock StandardCrypto)
-> SomeBackend SinkArgs
forall a b. (a -> b) -> a -> b
$ SomeHasFS IO
-> DiskSnapshot
-> LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> SinkArgs IO Mem LedgerState (CardanoBlock StandardCrypto)
mkInMemSinkArgs SomeHasFS IO
outSomeHasFS DiskSnapshot
outSnap LedgerState (CardanoBlock StandardCrypto) EmptyMK
st)
          ([Char]
"InMemory@[" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> DiskSnapshot -> [Char]
snapshotToDirName DiskSnapshot
outSnap [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"]")
          SnapshotBackend
UTxOHDMemSnapshot
    Snapshot (ExportedLSMSnapshot SnapshotsDirectory
_ (ExportedSnapshotPath [Char]
exportDir)) 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
$
        IO (SomeBackend SinkArgs)
-> [Char] -> SnapshotBackend -> OutEnv backend
forall backend.
IO (SomeBackend SinkArgs)
-> [Char] -> SnapshotBackend -> OutEnv backend
OutEnv
          ( SinkArgs IO LSM LedgerState (CardanoBlock StandardCrypto)
-> SomeBackend SinkArgs
forall backend
       (c :: (* -> *) -> * -> (* -> MapKind -> *) -> * -> *).
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
<$> [Char]
-> DiskSnapshot
-> SomeHasFS IO
-> ([Char] -> WithTempRegistry () IO (SomeHasFSAndBlockIO IO))
-> IO StdGen
-> IO (SinkArgs IO LSM LedgerState (CardanoBlock StandardCrypto))
forall (m :: * -> *) (l :: * -> MapKind -> *) blk.
IOLike m =>
[Char]
-> DiskSnapshot
-> SomeHasFS m
-> ([Char] -> WithTempRegistry () m (SomeHasFSAndBlockIO m))
-> m StdGen
-> m (SinkArgs m LSM l blk)
mkExportedLSMSinkArgs
                [Char]
exportDir
                DiskSnapshot
outSnap
                SomeHasFS IO
outSomeHasFS
                [Char] -> WithTempRegistry () IO (SomeHasFSAndBlockIO IO)
forall st.
[Char] -> WithTempRegistry st IO (SomeHasFSAndBlockIO IO)
stdMkBlockIOFS
                IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
          )
          ([Char]
"LSM (exported)@[" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
exportDir [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"]")
          SnapshotBackend
UTxOHDLSMSnapshot

  stream ::
    LedgerState (CardanoBlock StandardCrypto) EmptyMK ->
    IO (SomeBackend YieldArgs) ->
    IO (SomeBackend SinkArgs) ->
    ExceptT DeserialiseFailure IO (Maybe CRC, Maybe CRC)
  stream :: LedgerState (CardanoBlock StandardCrypto) EmptyMK
-> IO (SomeBackend YieldArgs)
-> IO (SomeBackend SinkArgs)
-> ExceptT DeserialiseFailure IO (Maybe CRC, Maybe CRC)
stream LedgerState (CardanoBlock StandardCrypto) EmptyMK
st IO (SomeBackend YieldArgs)
mYieldArgs 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
$
      IO (SomeBackend YieldArgs, SomeBackend SinkArgs)
-> ((SomeBackend YieldArgs, SomeBackend SinkArgs) -> IO ())
-> ((SomeBackend YieldArgs, SomeBackend SinkArgs)
    -> IO (Either DeserialiseFailure (Maybe CRC, Maybe CRC)))
-> IO (Either DeserialiseFailure (Maybe CRC, Maybe CRC))
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
        ((,) (SomeBackend YieldArgs
 -> SomeBackend SinkArgs
 -> (SomeBackend YieldArgs, SomeBackend SinkArgs))
-> IO (SomeBackend YieldArgs)
-> IO
     (SomeBackend SinkArgs
      -> (SomeBackend YieldArgs, SomeBackend SinkArgs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (SomeBackend YieldArgs)
mYieldArgs IO
  (SomeBackend SinkArgs
   -> (SomeBackend YieldArgs, SomeBackend SinkArgs))
-> IO (SomeBackend SinkArgs)
-> IO (SomeBackend YieldArgs, SomeBackend SinkArgs)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (SomeBackend SinkArgs)
mSinkArgs)
        ( \( SomeBackend (YieldArgs IO backend LedgerState (CardanoBlock StandardCrypto)
yArgs :: YieldArgs IO backend1 l (CardanoBlock StandardCrypto))
             , (SomeBackend (SinkArgs IO backend LedgerState (CardanoBlock StandardCrypto)
sArgs :: SinkArgs IO backend2 l (CardanoBlock StandardCrypto)))
             ) -> do
              YieldArgs IO backend LedgerState (CardanoBlock StandardCrypto)
-> IO ()
forall (m :: * -> *) backend (l :: * -> MapKind -> *) blk.
StreamingBackend m backend l blk =>
YieldArgs m backend l blk -> m ()
releaseYieldArgs YieldArgs IO backend LedgerState (CardanoBlock StandardCrypto)
yArgs
              SinkArgs IO backend LedgerState (CardanoBlock StandardCrypto)
-> IO ()
forall (m :: * -> *) backend (l :: * -> MapKind -> *) blk.
StreamingBackend m backend l blk =>
SinkArgs m backend l blk -> m ()
releaseSinkArgs SinkArgs IO backend LedgerState (CardanoBlock StandardCrypto)
sArgs
        )
        ( \( SomeBackend (YieldArgs IO backend LedgerState (CardanoBlock StandardCrypto)
yArgs :: YieldArgs IO backend1 l (CardanoBlock StandardCrypto))
             , (SomeBackend (SinkArgs IO backend LedgerState (CardanoBlock StandardCrypto)
sArgs :: SinkArgs IO backend2 l (CardanoBlock StandardCrypto)))
             ) -> do
              ExceptT DeserialiseFailure IO (Maybe CRC, Maybe CRC)
-> IO (Either DeserialiseFailure (Maybe CRC, Maybe CRC))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT DeserialiseFailure IO (Maybe CRC, Maybe CRC)
 -> IO (Either DeserialiseFailure (Maybe CRC, Maybe CRC)))
-> ExceptT DeserialiseFailure IO (Maybe CRC, Maybe CRC)
-> IO (Either DeserialiseFailure (Maybe CRC, Maybe CRC))
forall a b. (a -> b) -> a -> b
$ Proxy backend
-> YieldArgs IO backend LedgerState (CardanoBlock StandardCrypto)
-> Yield IO LedgerState (CardanoBlock StandardCrypto)
forall (m :: * -> *) backend (l :: * -> MapKind -> *) blk.
StreamingBackend m backend l blk =>
Proxy backend -> YieldArgs m backend l blk -> Yield m l blk
yield (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @backend1) YieldArgs IO backend LedgerState (CardanoBlock StandardCrypto)
yArgs LedgerState (CardanoBlock StandardCrypto) EmptyMK
st ((Stream
    (Of
       (TxIn (CardanoBlock StandardCrypto),
        TxOut (CardanoBlock StandardCrypto)))
    (ExceptT DeserialiseFailure IO)
    (Stream (Of ByteString) IO (Maybe CRC))
  -> ExceptT
       DeserialiseFailure
       IO
       (Stream (Of ByteString) IO (Maybe CRC, Maybe CRC)))
 -> ExceptT DeserialiseFailure IO (Maybe CRC, Maybe CRC))
-> (Stream
      (Of
         (TxIn (CardanoBlock StandardCrypto),
          TxOut (CardanoBlock StandardCrypto)))
      (ExceptT DeserialiseFailure IO)
      (Stream (Of ByteString) IO (Maybe CRC))
    -> ExceptT
         DeserialiseFailure
         IO
         (Stream (Of ByteString) IO (Maybe CRC, Maybe CRC)))
-> ExceptT DeserialiseFailure IO (Maybe CRC, Maybe CRC)
forall a b. (a -> b) -> a -> b
$ Proxy backend
-> SinkArgs IO backend LedgerState (CardanoBlock StandardCrypto)
-> Sink IO LedgerState (CardanoBlock StandardCrypto)
forall (m :: * -> *) backend (l :: * -> MapKind -> *) blk.
StreamingBackend m backend l blk =>
Proxy backend -> SinkArgs m backend l blk -> Sink m l blk
sink (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @backend2) SinkArgs IO backend LedgerState (CardanoBlock StandardCrypto)
sArgs LedgerState (CardanoBlock StandardCrypto) EmptyMK
st
        )

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

niceAnimatedProgressBar :: String -> String -> IO (Maybe (Async IO ()))
niceAnimatedProgressBar :: [Char] -> [Char] -> IO (Maybe (Async IO ()))
niceAnimatedProgressBar [Char]
inMsg [Char]
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 -> [Char] -> IO ()
putColored Color
c Bool
b [Char]
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
-> [Char]
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO a
askForConfirmation Bool
False ExceptT (Error (CardanoBlock StandardCrypto)) IO a
act [Char]
_ = ExceptT (Error (CardanoBlock StandardCrypto)) IO a
act
askForConfirmation Bool
True ExceptT (Error (CardanoBlock StandardCrypto)) IO a
act [Char]
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 -> [Char] -> IO ()
putColored Color
Yellow Bool
False ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"I'm going to " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
infoMsg [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
". Continue? (Y/n) "
  answer <- IO [Char]
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO [Char]
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 [Char]
 -> ExceptT (Error (CardanoBlock StandardCrypto)) IO [Char])
-> IO [Char]
-> ExceptT (Error (CardanoBlock StandardCrypto)) IO [Char]
forall a b. (a -> b) -> a -> b
$ IO [Char]
getLine
  case map toLower answer of
    [Char]
"y" -> ExceptT (Error (CardanoBlock StandardCrypto)) IO a
act
    [Char]
_ -> 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
-> [Char] -> ExceptT (Error (CardanoBlock StandardCrypto)) IO ()
wipePath Bool
interactive [Char]
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
$ [Char] -> IO Bool
D.doesDirectoryExist [Char]
fp
  ( if exists
      then flip (askForConfirmation interactive) ("wipe the path " <> fp)
      else id
    )
    (lift $ D.removePathForcibly fp >> D.createDirectoryIfMissing True fp)