{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}

module Ouroboros.Consensus.Storage.ImmutableDB.Impl.Validation (
    ValidateEnv (..)
  , validateAndReopen
    -- * Exported for testing purposes
  , ShouldBeFinalised (..)
  , reconstructPrimaryIndex
  ) where

import           Control.Exception (assert)
import           Control.Monad (forM_, unless, when)
import           Control.Monad.Except (ExceptT, runExceptT, throwError)
import           Control.Monad.Trans.Class (lift)
import           Control.Tracer (Tracer, contramap, traceWith)
import qualified Data.ByteString.Lazy as Lazy
import           Data.Functor (($>))
import           Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.Set as Set
import           GHC.Stack (HasCallStack)
import           Ouroboros.Consensus.Block hiding (hashSize)
import           Ouroboros.Consensus.Storage.ImmutableDB.API
import           Ouroboros.Consensus.Storage.ImmutableDB.Chunks
import           Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal
                     (unChunkNo, unsafeEpochNoToChunkNo)
import           Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index
                     (cachedIndex)
import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index as Index
import           Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Primary
                     (PrimaryIndex)
import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Primary as Primary
import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Secondary as Secondary
import           Ouroboros.Consensus.Storage.ImmutableDB.Impl.Parser
                     (BlockSummary (..), parseChunkFile)
import           Ouroboros.Consensus.Storage.ImmutableDB.Impl.State
import           Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types
import           Ouroboros.Consensus.Storage.ImmutableDB.Impl.Util
import           Ouroboros.Consensus.Storage.Serialisation (DecodeDisk (..),
                     HasBinaryBlockInfo (..))
import           Ouroboros.Consensus.Util (lastMaybe, whenJust)
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.ResourceRegistry
import           Streaming (Of (..))
import qualified Streaming.Prelude as S
import           System.FS.API

-- | Bundle of arguments used most validation functions.
--
-- Note that we don't use "Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index"
-- because we are reading and manipulating index files in different ways, e.g.,
-- truncating them.
data ValidateEnv m blk h = ValidateEnv {
      forall (m :: * -> *) blk h. ValidateEnv m blk h -> HasFS m h
hasFS          :: !(HasFS m h)
    , forall (m :: * -> *) blk h. ValidateEnv m blk h -> ChunkInfo
chunkInfo      :: !ChunkInfo
    , forall (m :: * -> *) blk h.
ValidateEnv m blk h -> Tracer m (TraceEvent blk)
tracer         :: !(Tracer m (TraceEvent blk))
    , forall (m :: * -> *) blk h. ValidateEnv m blk h -> CacheConfig
cacheConfig    :: !Index.CacheConfig
    , forall (m :: * -> *) blk h. ValidateEnv m blk h -> CodecConfig blk
codecConfig    :: !(CodecConfig blk)
    , forall (m :: * -> *) blk h. ValidateEnv m blk h -> blk -> Bool
checkIntegrity :: !(blk -> Bool)
    }

-- | Perform validation as per the 'ValidationPolicy' using 'validate' and
-- create an 'OpenState' corresponding to its outcome using 'mkOpenState'.
validateAndReopen ::
     forall m blk h.
     ( IOLike m
     , GetPrevHash blk
     , HasBinaryBlockInfo blk
     , DecodeDisk blk (Lazy.ByteString -> blk)
     , ConvertRawHash blk
     , Eq h
     , HasCallStack
     )
  => ValidateEnv m blk h
  -> ResourceRegistry m
  -> ValidationPolicy
  -> WithTempRegistry (OpenState m blk h) m (OpenState m blk h)
validateAndReopen :: forall (m :: * -> *) blk h.
(IOLike m, GetPrevHash blk, HasBinaryBlockInfo blk,
 DecodeDisk blk (ByteString -> blk), ConvertRawHash blk, Eq h,
 HasCallStack) =>
ValidateEnv m blk h
-> ResourceRegistry m
-> ValidationPolicy
-> WithTempRegistry (OpenState m blk h) m (OpenState m blk h)
validateAndReopen ValidateEnv m blk h
validateEnv ResourceRegistry m
registry ValidationPolicy
valPol = Proxy blk
-> WithTempRegistry (OpenState m blk h) m (OpenState m blk h)
-> WithTempRegistry (OpenState m blk h) m (OpenState m blk h)
forall blk (m :: * -> *) a.
(MonadCatch m, StandardHash blk, Typeable blk) =>
Proxy blk -> m a -> m a
wrapFsError (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) (WithTempRegistry (OpenState m blk h) m (OpenState m blk h)
 -> WithTempRegistry (OpenState m blk h) m (OpenState m blk h))
-> WithTempRegistry (OpenState m blk h) m (OpenState m blk h)
-> WithTempRegistry (OpenState m blk h) m (OpenState m blk h)
forall a b. (a -> b) -> a -> b
$ do
    (ChunkNo
chunk, WithOrigin (Tip blk)
tip) <- m (ChunkNo, WithOrigin (Tip blk))
-> WithTempRegistry
     (OpenState m blk h) m (ChunkNo, WithOrigin (Tip blk))
forall (m :: * -> *) a.
Monad m =>
m a -> WithTempRegistry (OpenState m blk h) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (ChunkNo, WithOrigin (Tip blk))
 -> WithTempRegistry
      (OpenState m blk h) m (ChunkNo, WithOrigin (Tip blk)))
-> m (ChunkNo, WithOrigin (Tip blk))
-> WithTempRegistry
     (OpenState m blk h) m (ChunkNo, WithOrigin (Tip blk))
forall a b. (a -> b) -> a -> b
$ ValidateEnv m blk h
-> ValidationPolicy -> m (ChunkNo, WithOrigin (Tip blk))
forall (m :: * -> *) blk h.
(IOLike m, GetPrevHash blk, HasBinaryBlockInfo blk,
 DecodeDisk blk (ByteString -> blk), ConvertRawHash blk,
 HasCallStack) =>
ValidateEnv m blk h
-> ValidationPolicy -> m (ChunkNo, WithOrigin (Tip blk))
validate ValidateEnv m blk h
validateEnv ValidationPolicy
valPol
    Index m blk h
index        <- m (Index m blk h)
-> WithTempRegistry (OpenState m blk h) m (Index m blk h)
forall (m :: * -> *) a.
Monad m =>
m a -> WithTempRegistry (OpenState m blk h) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Index m blk h)
 -> WithTempRegistry (OpenState m blk h) m (Index m blk h))
-> m (Index m blk h)
-> WithTempRegistry (OpenState m blk h) m (Index m blk h)
forall a b. (a -> b) -> a -> b
$ HasFS m h
-> ResourceRegistry m
-> Tracer m TraceCacheEvent
-> CacheConfig
-> ChunkInfo
-> ChunkNo
-> m (Index m blk h)
forall (m :: * -> *) blk h.
(IOLike m, ConvertRawHash blk, StandardHash blk, Typeable blk) =>
HasFS m h
-> ResourceRegistry m
-> Tracer m TraceCacheEvent
-> CacheConfig
-> ChunkInfo
-> ChunkNo
-> m (Index m blk h)
cachedIndex
                      HasFS m h
hasFS
                      ResourceRegistry m
registry
                      Tracer m TraceCacheEvent
cacheTracer
                      CacheConfig
cacheConfig
                      ChunkInfo
chunkInfo
                      ChunkNo
chunk
    case WithOrigin (Tip blk)
tip of
      WithOrigin (Tip blk)
Origin -> Bool
-> WithTempRegistry (OpenState m blk h) m (OpenState m blk h)
-> WithTempRegistry (OpenState m blk h) m (OpenState m blk h)
forall a. HasCallStack => Bool -> a -> a
assert (ChunkNo
chunk ChunkNo -> ChunkNo -> Bool
forall a. Eq a => a -> a -> Bool
== ChunkNo
firstChunkNo) (WithTempRegistry (OpenState m blk h) m (OpenState m blk h)
 -> WithTempRegistry (OpenState m blk h) m (OpenState m blk h))
-> WithTempRegistry (OpenState m blk h) m (OpenState m blk h)
-> WithTempRegistry (OpenState m blk h) m (OpenState m blk h)
forall a b. (a -> b) -> a -> b
$ do
        m () -> WithTempRegistry (OpenState m blk h) m ()
forall (m :: * -> *) a.
Monad m =>
m a -> WithTempRegistry (OpenState m blk h) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WithTempRegistry (OpenState m blk h) m ())
-> m () -> WithTempRegistry (OpenState m blk h) m ()
forall a b. (a -> b) -> a -> b
$ Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer TraceEvent blk
forall blk. TraceEvent blk
NoValidLastLocation
        HasFS m h
-> Index m blk h
-> ChunkNo
-> WithOrigin (Tip blk)
-> AllowExisting
-> WithTempRegistry (OpenState m blk h) m (OpenState m blk h)
forall (m :: * -> *) blk h.
(HasCallStack, IOLike m, Eq h) =>
HasFS m h
-> Index m blk h
-> ChunkNo
-> WithOrigin (Tip blk)
-> AllowExisting
-> WithTempRegistry (OpenState m blk h) m (OpenState m blk h)
mkOpenState HasFS m h
hasFS Index m blk h
index ChunkNo
chunk WithOrigin (Tip blk)
forall t. WithOrigin t
Origin AllowExisting
MustBeNew
      NotOrigin Tip blk
tip' -> do
        m () -> WithTempRegistry (OpenState m blk h) m ()
forall (m :: * -> *) a.
Monad m =>
m a -> WithTempRegistry (OpenState m blk h) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WithTempRegistry (OpenState m blk h) m ())
-> m () -> WithTempRegistry (OpenState m blk h) m ()
forall a b. (a -> b) -> a -> b
$ Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer (TraceEvent blk -> m ()) -> TraceEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ ChunkNo -> Tip blk -> TraceEvent blk
forall blk. ChunkNo -> Tip blk -> TraceEvent blk
ValidatedLastLocation ChunkNo
chunk Tip blk
tip'
        HasFS m h
-> Index m blk h
-> ChunkNo
-> WithOrigin (Tip blk)
-> AllowExisting
-> WithTempRegistry (OpenState m blk h) m (OpenState m blk h)
forall (m :: * -> *) blk h.
(HasCallStack, IOLike m, Eq h) =>
HasFS m h
-> Index m blk h
-> ChunkNo
-> WithOrigin (Tip blk)
-> AllowExisting
-> WithTempRegistry (OpenState m blk h) m (OpenState m blk h)
mkOpenState HasFS m h
hasFS Index m blk h
index ChunkNo
chunk WithOrigin (Tip blk)
tip AllowExisting
AllowExisting
  where
    ValidateEnv { HasFS m h
hasFS :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> HasFS m h
hasFS :: HasFS m h
hasFS, Tracer m (TraceEvent blk)
tracer :: forall (m :: * -> *) blk h.
ValidateEnv m blk h -> Tracer m (TraceEvent blk)
tracer :: Tracer m (TraceEvent blk)
tracer, CacheConfig
cacheConfig :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> CacheConfig
cacheConfig :: CacheConfig
cacheConfig, ChunkInfo
chunkInfo :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> ChunkInfo
chunkInfo :: ChunkInfo
chunkInfo } = ValidateEnv m blk h
validateEnv
    cacheTracer :: Tracer m TraceCacheEvent
cacheTracer = (TraceCacheEvent -> TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m TraceCacheEvent
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap TraceCacheEvent -> TraceEvent blk
forall blk. TraceCacheEvent -> TraceEvent blk
TraceCacheEvent Tracer m (TraceEvent blk)
tracer

-- | Execute the 'ValidationPolicy'.
--
-- Migrates first.
--
-- NOTE: we don't use a 'ResourceRegistry' to allocate file handles in,
-- because validation happens on startup, so when an exception is thrown, the
-- database hasn't even been opened and the node will shut down. In which case
-- we don't have to worry about leaking handles, they will be closed when the
-- process terminates.
validate ::
     forall m blk h.
     ( IOLike m
     , GetPrevHash blk
     , HasBinaryBlockInfo blk
     , DecodeDisk blk (Lazy.ByteString -> blk)
     , ConvertRawHash blk
     , HasCallStack
     )
  => ValidateEnv m blk h
  -> ValidationPolicy
  -> m (ChunkNo, WithOrigin (Tip blk))
validate :: forall (m :: * -> *) blk h.
(IOLike m, GetPrevHash blk, HasBinaryBlockInfo blk,
 DecodeDisk blk (ByteString -> blk), ConvertRawHash blk,
 HasCallStack) =>
ValidateEnv m blk h
-> ValidationPolicy -> m (ChunkNo, WithOrigin (Tip blk))
validate validateEnv :: ValidateEnv m blk h
validateEnv@ValidateEnv{ HasFS m h
hasFS :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> HasFS m h
hasFS :: HasFS m h
hasFS, Tracer m (TraceEvent blk)
tracer :: forall (m :: * -> *) blk h.
ValidateEnv m blk h -> Tracer m (TraceEvent blk)
tracer :: Tracer m (TraceEvent blk)
tracer } ValidationPolicy
valPol = do

    -- First migrate any old files before validating them
    ValidateEnv m blk h -> m ()
forall (m :: * -> *) blk h.
(IOLike m, HasCallStack) =>
ValidateEnv m blk h -> m ()
migrate ValidateEnv m blk h
validateEnv

    Set String
filesInDBFolder <- HasCallStack => FsPath -> m (Set String)
FsPath -> m (Set String)
listDirectory ([String] -> FsPath
mkFsPath [])
    let (Set ChunkNo
chunkFiles, Set ChunkNo
_, Set ChunkNo
_) = Set String -> (Set ChunkNo, Set ChunkNo, Set ChunkNo)
dbFilesOnDisk Set String
filesInDBFolder
    case Set ChunkNo -> Maybe ChunkNo
forall a. Set a -> Maybe a
Set.lookupMax Set ChunkNo
chunkFiles of
      Maybe ChunkNo
Nothing              -> do
        -- Remove left-over index files
        -- TODO calls listDirectory again
        HasFS m h -> ChunkNo -> m ()
forall (m :: * -> *) h.
(HasCallStack, Monad m) =>
HasFS m h -> ChunkNo -> m ()
removeFilesStartingFrom HasFS m h
hasFS ChunkNo
firstChunkNo
        (ChunkNo, WithOrigin (Tip blk))
-> m (ChunkNo, WithOrigin (Tip blk))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ChunkNo
firstChunkNo, WithOrigin (Tip blk)
forall t. WithOrigin t
Origin)

      Just ChunkNo
lastChunkOnDisk ->
        let validateTracer :: Tracer m (TraceChunkValidation blk ())
validateTracer =
              ChunkNo
-> Tracer m (TraceEvent blk)
-> Tracer m (TraceChunkValidation blk ())
decorateValidateTracer
                ChunkNo
lastChunkOnDisk
                Tracer m (TraceEvent blk)
tracer
        in
         case ValidationPolicy
valPol of
          ValidationPolicy
ValidateAllChunks       ->
            ValidateEnv m blk h
-> Tracer m (TraceChunkValidation blk ())
-> ChunkNo
-> m (ChunkNo, WithOrigin (Tip blk))
forall (m :: * -> *) blk h.
(IOLike m, GetPrevHash blk, HasBinaryBlockInfo blk,
 DecodeDisk blk (ByteString -> blk), ConvertRawHash blk,
 HasCallStack) =>
ValidateEnv m blk h
-> Tracer m (TraceChunkValidation blk ())
-> ChunkNo
-> m (ChunkNo, WithOrigin (Tip blk))
validateAllChunks       ValidateEnv m blk h
validateEnv Tracer m (TraceChunkValidation blk ())
validateTracer ChunkNo
lastChunkOnDisk
          ValidationPolicy
ValidateMostRecentChunk ->
            ValidateEnv m blk h
-> Tracer m (TraceChunkValidation blk ())
-> ChunkNo
-> m (ChunkNo, WithOrigin (Tip blk))
forall (m :: * -> *) blk h.
(IOLike m, GetPrevHash blk, HasBinaryBlockInfo blk,
 DecodeDisk blk (ByteString -> blk), ConvertRawHash blk,
 HasCallStack) =>
ValidateEnv m blk h
-> Tracer m (TraceChunkValidation blk ())
-> ChunkNo
-> m (ChunkNo, WithOrigin (Tip blk))
validateMostRecentChunk ValidateEnv m blk h
validateEnv Tracer m (TraceChunkValidation blk ())
validateTracer ChunkNo
lastChunkOnDisk
  where
    HasFS { HasCallStack => FsPath -> m (Set String)
listDirectory :: HasCallStack => FsPath -> m (Set String)
listDirectory :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m (Set String)
listDirectory } = HasFS m h
hasFS

    -- | Using the Functor instance of TraceChunkValidation, by a contravariant
    -- tracer annotate the event with the total number of chunks on the relevant
    -- constructors of the datatype.
    decorateValidateTracer
        :: ChunkNo
        -> Tracer m (TraceEvent blk)
        -> Tracer m (TraceChunkValidation blk ())
    decorateValidateTracer :: ChunkNo
-> Tracer m (TraceEvent blk)
-> Tracer m (TraceChunkValidation blk ())
decorateValidateTracer ChunkNo
c' =
      (TraceChunkValidation blk () -> TraceEvent blk)
-> Tracer m (TraceEvent blk)
-> Tracer m (TraceChunkValidation blk ())
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (TraceChunkValidation blk ChunkNo -> TraceEvent blk
forall blk. TraceChunkValidation blk ChunkNo -> TraceEvent blk
ChunkValidationEvent (TraceChunkValidation blk ChunkNo -> TraceEvent blk)
-> (TraceChunkValidation blk ()
    -> TraceChunkValidation blk ChunkNo)
-> TraceChunkValidation blk ()
-> TraceEvent blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() -> ChunkNo)
-> TraceChunkValidation blk () -> TraceChunkValidation blk ChunkNo
forall a b.
(a -> b)
-> TraceChunkValidation blk a -> TraceChunkValidation blk b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ChunkNo -> () -> ChunkNo
forall a b. a -> b -> a
const ChunkNo
c'))


-- | Validate chunks from oldest to newest, stop after the most recent chunk
-- on disk. During this validation, keep track of the last valid block we
-- encountered. If at the end, that block is not in the last chunk on disk,
-- remove the chunk and index files after that chunk.
validateAllChunks ::
     forall m blk h.
     ( IOLike m
     , GetPrevHash blk
     , HasBinaryBlockInfo blk
     , DecodeDisk blk (Lazy.ByteString -> blk)
     , ConvertRawHash blk
     , HasCallStack
     )
  => ValidateEnv m blk h
  -> Tracer m (TraceChunkValidation blk ())
  -> ChunkNo
     -- ^ Most recent chunk on disk
  -> m (ChunkNo, WithOrigin (Tip blk))
validateAllChunks :: forall (m :: * -> *) blk h.
(IOLike m, GetPrevHash blk, HasBinaryBlockInfo blk,
 DecodeDisk blk (ByteString -> blk), ConvertRawHash blk,
 HasCallStack) =>
ValidateEnv m blk h
-> Tracer m (TraceChunkValidation blk ())
-> ChunkNo
-> m (ChunkNo, WithOrigin (Tip blk))
validateAllChunks validateEnv :: ValidateEnv m blk h
validateEnv@ValidateEnv { HasFS m h
hasFS :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> HasFS m h
hasFS :: HasFS m h
hasFS, ChunkInfo
chunkInfo :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> ChunkInfo
chunkInfo :: ChunkInfo
chunkInfo } Tracer m (TraceChunkValidation blk ())
validateTracer ChunkNo
lastChunk =
    (ChunkNo, WithOrigin (Tip blk))
-> ChunkNo -> ChainHash blk -> m (ChunkNo, WithOrigin (Tip blk))
go (ChunkNo
firstChunkNo, WithOrigin (Tip blk)
forall t. WithOrigin t
Origin) ChunkNo
firstChunkNo ChainHash blk
forall {k} (b :: k). ChainHash b
GenesisHash
  where
    go ::
         (ChunkNo, WithOrigin (Tip blk))  -- ^ The last valid chunk and tip
      -> ChunkNo                          -- ^ The chunk to validate now
      -> ChainHash blk                    -- ^ The hash of the last block of
                                          -- the previous chunk
      -> m (ChunkNo, WithOrigin (Tip blk))
    go :: (ChunkNo, WithOrigin (Tip blk))
-> ChunkNo -> ChainHash blk -> m (ChunkNo, WithOrigin (Tip blk))
go (ChunkNo, WithOrigin (Tip blk))
lastValid ChunkNo
chunk ChainHash blk
prevHash = do
      let shouldBeFinalised :: ShouldBeFinalised
shouldBeFinalised =
            if ChunkNo
chunk ChunkNo -> ChunkNo -> Bool
forall a. Eq a => a -> a -> Bool
== ChunkNo
lastChunk
              then ShouldBeFinalised
ShouldNotBeFinalised
              else ShouldBeFinalised
ShouldBeFinalised
      ExceptT () m (Maybe (Tip blk)) -> m (Either () (Maybe (Tip blk)))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
        (ValidateEnv m blk h
-> ShouldBeFinalised
-> ChunkNo
-> Maybe (ChainHash blk)
-> Tracer m (TraceChunkValidation blk ())
-> ExceptT () m (Maybe (Tip blk))
forall (m :: * -> *) blk h.
(IOLike m, GetPrevHash blk, HasBinaryBlockInfo blk,
 DecodeDisk blk (ByteString -> blk), ConvertRawHash blk,
 HasCallStack) =>
ValidateEnv m blk h
-> ShouldBeFinalised
-> ChunkNo
-> Maybe (ChainHash blk)
-> Tracer m (TraceChunkValidation blk ())
-> ExceptT () m (Maybe (Tip blk))
validateChunk ValidateEnv m blk h
validateEnv ShouldBeFinalised
shouldBeFinalised ChunkNo
chunk (ChainHash blk -> Maybe (ChainHash blk)
forall a. a -> Maybe a
Just ChainHash blk
prevHash) Tracer m (TraceChunkValidation blk ())
validateTracer) m (Either () (Maybe (Tip blk)))
-> (Either () (Maybe (Tip blk))
    -> m (ChunkNo, WithOrigin (Tip blk)))
-> m (ChunkNo, WithOrigin (Tip blk))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left  ()              -> (ChunkNo, WithOrigin (Tip blk)) -> ChunkNo -> m ()
cleanup (ChunkNo, WithOrigin (Tip blk))
lastValid ChunkNo
chunk m ()
-> (ChunkNo, WithOrigin (Tip blk))
-> m (ChunkNo, WithOrigin (Tip blk))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (ChunkNo, WithOrigin (Tip blk))
lastValid
          Right Maybe (Tip blk)
Nothing         -> (ChunkNo, WithOrigin (Tip blk))
-> ChunkNo -> ChainHash blk -> m (ChunkNo, WithOrigin (Tip blk))
continueOrStop (ChunkNo, WithOrigin (Tip blk))
lastValid                   ChunkNo
chunk ChainHash blk
prevHash
          Right (Just Tip blk
validBlk) -> (ChunkNo, WithOrigin (Tip blk))
-> ChunkNo -> ChainHash blk -> m (ChunkNo, WithOrigin (Tip blk))
continueOrStop (ChunkNo
chunk, Tip blk -> WithOrigin (Tip blk)
forall t. t -> WithOrigin t
NotOrigin Tip blk
validBlk) ChunkNo
chunk ChainHash blk
prevHash'
            where
              prevHash' :: ChainHash blk
prevHash' = HeaderHash blk -> ChainHash blk
forall {k} (b :: k). HeaderHash b -> ChainHash b
BlockHash (Tip blk -> HeaderHash blk
forall blk. Tip blk -> HeaderHash blk
tipHash Tip blk
validBlk)

    -- | Validate the next chunk, unless the chunk just validated is the last
    -- chunk to validate. Cleanup files corresponding to chunks after the
    -- chunk in which we found the last valid block. Return that chunk and the
    -- tip corresponding to that block.
    continueOrStop ::
         (ChunkNo, WithOrigin (Tip blk))
      -> ChunkNo        -- ^ The chunk just validated
      -> ChainHash blk  -- ^ The hash of the last block of the previous chunk
      -> m (ChunkNo, WithOrigin (Tip blk))
    continueOrStop :: (ChunkNo, WithOrigin (Tip blk))
-> ChunkNo -> ChainHash blk -> m (ChunkNo, WithOrigin (Tip blk))
continueOrStop (ChunkNo, WithOrigin (Tip blk))
lastValid ChunkNo
chunk ChainHash blk
prevHash
      | ChunkNo
chunk ChunkNo -> ChunkNo -> Bool
forall a. Ord a => a -> a -> Bool
< ChunkNo
lastChunk
      = do
          Tracer m (TraceChunkValidation blk ())
-> TraceChunkValidation blk () -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChunkValidation blk ())
validateTracer (ChunkNo -> () -> TraceChunkValidation blk ()
forall blk validateTo.
ChunkNo -> validateTo -> TraceChunkValidation blk validateTo
ValidatedChunk ChunkNo
chunk ())
          (ChunkNo, WithOrigin (Tip blk))
-> ChunkNo -> ChainHash blk -> m (ChunkNo, WithOrigin (Tip blk))
go (ChunkNo, WithOrigin (Tip blk))
lastValid (ChunkNo -> ChunkNo
nextChunkNo ChunkNo
chunk) ChainHash blk
prevHash
      | Bool
otherwise
      = Bool
-> m (ChunkNo, WithOrigin (Tip blk))
-> m (ChunkNo, WithOrigin (Tip blk))
forall a. HasCallStack => Bool -> a -> a
assert (ChunkNo
chunk ChunkNo -> ChunkNo -> Bool
forall a. Eq a => a -> a -> Bool
== ChunkNo
lastChunk) (m (ChunkNo, WithOrigin (Tip blk))
 -> m (ChunkNo, WithOrigin (Tip blk)))
-> m (ChunkNo, WithOrigin (Tip blk))
-> m (ChunkNo, WithOrigin (Tip blk))
forall a b. (a -> b) -> a -> b
$ do
        -- Cleanup is only needed when the final chunk was empty, yet valid.
        (ChunkNo, WithOrigin (Tip blk)) -> ChunkNo -> m ()
cleanup (ChunkNo, WithOrigin (Tip blk))
lastValid ChunkNo
chunk
        (ChunkNo, WithOrigin (Tip blk))
-> m (ChunkNo, WithOrigin (Tip blk))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ChunkNo, WithOrigin (Tip blk))
lastValid

    -- | Remove left over files from chunks newer than the last chunk
    -- containing a valid file. Also unfinalise it if necessary.
    cleanup ::
         (ChunkNo, WithOrigin (Tip blk))  -- ^ The last valid chunk and tip
      -> ChunkNo  -- ^ The last validated chunk, could have been invalid or
                  -- empty
      -> m ()
    cleanup :: (ChunkNo, WithOrigin (Tip blk)) -> ChunkNo -> m ()
cleanup (ChunkNo
lastValidChunk, WithOrigin (Tip blk)
tip) ChunkNo
lastValidatedChunk = case WithOrigin (Tip blk)
tip of
      WithOrigin (Tip blk)
Origin ->
        HasFS m h -> ChunkNo -> m ()
forall (m :: * -> *) h.
(HasCallStack, Monad m) =>
HasFS m h -> ChunkNo -> m ()
removeFilesStartingFrom HasFS m h
hasFS ChunkNo
firstChunkNo
      NotOrigin Tip blk
_ -> do
        HasFS m h -> ChunkNo -> m ()
forall (m :: * -> *) h.
(HasCallStack, Monad m) =>
HasFS m h -> ChunkNo -> m ()
removeFilesStartingFrom HasFS m h
hasFS (ChunkNo -> ChunkNo
nextChunkNo ChunkNo
lastValidChunk)
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ChunkNo
lastValidChunk ChunkNo -> ChunkNo -> Bool
forall a. Ord a => a -> a -> Bool
< ChunkNo
lastValidatedChunk) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          Proxy blk -> HasFS m h -> ChunkInfo -> ChunkNo -> m ()
forall (m :: * -> *) blk h.
(HasCallStack, MonadThrow m, StandardHash blk, Typeable blk) =>
Proxy blk -> HasFS m h -> ChunkInfo -> ChunkNo -> m ()
Primary.unfinalise (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) HasFS m h
hasFS ChunkInfo
chunkInfo ChunkNo
lastValidChunk

-- | Validate the given most recent chunk. If that chunk contains no valid
-- block, try the chunk before it, and so on. Stop as soon as an chunk with a
-- valid block is found, returning that chunk and the tip corresponding to
-- that block. If no valid blocks are found, chunk 0 and 'TipGen' is returned.
validateMostRecentChunk ::
     forall m blk h.
     ( IOLike m
     , GetPrevHash blk
     , HasBinaryBlockInfo blk
     , DecodeDisk blk (Lazy.ByteString -> blk)
     , ConvertRawHash blk
     , HasCallStack
     )
  => ValidateEnv m blk h
  -> Tracer m (TraceChunkValidation blk ())
  -> ChunkNo
     -- ^ Most recent chunk on disk, the chunk to validate
  -> m (ChunkNo, WithOrigin (Tip blk))
validateMostRecentChunk :: forall (m :: * -> *) blk h.
(IOLike m, GetPrevHash blk, HasBinaryBlockInfo blk,
 DecodeDisk blk (ByteString -> blk), ConvertRawHash blk,
 HasCallStack) =>
ValidateEnv m blk h
-> Tracer m (TraceChunkValidation blk ())
-> ChunkNo
-> m (ChunkNo, WithOrigin (Tip blk))
validateMostRecentChunk validateEnv :: ValidateEnv m blk h
validateEnv@ValidateEnv { HasFS m h
hasFS :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> HasFS m h
hasFS :: HasFS m h
hasFS } Tracer m (TraceChunkValidation blk ())
validateTracer ChunkNo
c = do
    (ChunkNo, WithOrigin (Tip blk))
res <- ChunkNo -> m (ChunkNo, WithOrigin (Tip blk))
go ChunkNo
c
    Tracer m (TraceChunkValidation blk ())
-> TraceChunkValidation blk () -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChunkValidation blk ())
validateTracer (ChunkNo -> () -> TraceChunkValidation blk ()
forall blk validateTo.
ChunkNo -> validateTo -> TraceChunkValidation blk validateTo
ValidatedChunk ChunkNo
c ())
    (ChunkNo, WithOrigin (Tip blk))
-> m (ChunkNo, WithOrigin (Tip blk))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ChunkNo, WithOrigin (Tip blk))
res
  where
    go :: ChunkNo -> m (ChunkNo, WithOrigin (Tip blk))
    go :: ChunkNo -> m (ChunkNo, WithOrigin (Tip blk))
go ChunkNo
chunk = ExceptT () m (Maybe (Tip blk)) -> m (Either () (Maybe (Tip blk)))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
      (ValidateEnv m blk h
-> ShouldBeFinalised
-> ChunkNo
-> Maybe (ChainHash blk)
-> Tracer m (TraceChunkValidation blk ())
-> ExceptT () m (Maybe (Tip blk))
forall (m :: * -> *) blk h.
(IOLike m, GetPrevHash blk, HasBinaryBlockInfo blk,
 DecodeDisk blk (ByteString -> blk), ConvertRawHash blk,
 HasCallStack) =>
ValidateEnv m blk h
-> ShouldBeFinalised
-> ChunkNo
-> Maybe (ChainHash blk)
-> Tracer m (TraceChunkValidation blk ())
-> ExceptT () m (Maybe (Tip blk))
validateChunk ValidateEnv m blk h
validateEnv ShouldBeFinalised
ShouldNotBeFinalised ChunkNo
chunk Maybe (ChainHash blk)
forall a. Maybe a
Nothing Tracer m (TraceChunkValidation blk ())
validateTracer) m (Either () (Maybe (Tip blk)))
-> (Either () (Maybe (Tip blk))
    -> m (ChunkNo, WithOrigin (Tip blk)))
-> m (ChunkNo, WithOrigin (Tip blk))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right (Just Tip blk
validBlk) -> do
            -- Found a valid block, we can stop now.
            HasFS m h -> ChunkNo -> m ()
forall (m :: * -> *) h.
(HasCallStack, Monad m) =>
HasFS m h -> ChunkNo -> m ()
removeFilesStartingFrom HasFS m h
hasFS (ChunkNo -> ChunkNo
nextChunkNo ChunkNo
chunk)
            (ChunkNo, WithOrigin (Tip blk))
-> m (ChunkNo, WithOrigin (Tip blk))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ChunkNo
chunk, Tip blk -> WithOrigin (Tip blk)
forall t. t -> WithOrigin t
NotOrigin Tip blk
validBlk)
        Either () (Maybe (Tip blk))
_  -- This chunk file is unusable: either the chunk is empty or
           -- everything after it should be truncated.
          | Just ChunkNo
chunk' <- ChunkNo -> Maybe ChunkNo
prevChunkNo ChunkNo
chunk -> ChunkNo -> m (ChunkNo, WithOrigin (Tip blk))
go ChunkNo
chunk'
          | Bool
otherwise -> do
            -- Found no valid blocks on disk.
            -- TODO be more precise in which cases we need which cleanup.
            HasFS m h -> ChunkNo -> m ()
forall (m :: * -> *) h.
(HasCallStack, Monad m) =>
HasFS m h -> ChunkNo -> m ()
removeFilesStartingFrom HasFS m h
hasFS ChunkNo
firstChunkNo
            (ChunkNo, WithOrigin (Tip blk))
-> m (ChunkNo, WithOrigin (Tip blk))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ChunkNo
firstChunkNo, WithOrigin (Tip blk)
forall t. WithOrigin t
Origin)

-- | Iff the chunk is the most recent chunk, it should not be finalised.
--
-- With finalising, we mean: if there are one or more empty slots at the end
-- of the chunk, the primary index should be padded with offsets to indicate
-- that these slots are empty. See 'Primary.backfill'.
data ShouldBeFinalised =
    ShouldBeFinalised
  | ShouldNotBeFinalised
  deriving (Int -> ShouldBeFinalised -> ShowS
[ShouldBeFinalised] -> ShowS
ShouldBeFinalised -> String
(Int -> ShouldBeFinalised -> ShowS)
-> (ShouldBeFinalised -> String)
-> ([ShouldBeFinalised] -> ShowS)
-> Show ShouldBeFinalised
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ShouldBeFinalised -> ShowS
showsPrec :: Int -> ShouldBeFinalised -> ShowS
$cshow :: ShouldBeFinalised -> String
show :: ShouldBeFinalised -> String
$cshowList :: [ShouldBeFinalised] -> ShowS
showList :: [ShouldBeFinalised] -> ShowS
Show)

-- | Validate the given chunk
--
-- * Invalid or missing chunk files will cause truncation. All blocks after a
--   gap in blocks (due to a missing blocks or invalid block(s)) are
--   truncated.
--
-- * Chunk files are the main source of truth. Primary and secondary index
--   files can be reconstructed from the chunk files using the
--   'ChunkFileParser'. If index files are missing, corrupt, or do not match
--   the chunk files, they are overwritten.
--
-- * The 'ChunkFileParser' checks whether the hashes (header hash) line up
--   within an chunk. When they do not, we truncate the chunk, including the
--   block of which its previous hash does not match the hash of the previous
--   block.
--
-- * For each block, the 'ChunkFileParser' checks whether the checksum (and
--   other fields) from the secondary index file match the ones retrieved from
--   the actual block. If they do, the block has not been corrupted. If they
--   don't match or if the secondary index file is missing or corrupt, we have
--   to do the expensive integrity check of the block itself to determine
--   whether it is corrupt or not.
--
-- * This function checks whether the first block in the chunk fits onto the
--   last block of the previous chunk by checking the hashes. If they do not
--   fit, this chunk is truncated and @()@ is thrown.
--
-- * When an invalid block needs to be truncated, trailing empty slots are
--   also truncated so that the tip of the database will always point to a
--   valid block or EBB.
--
-- * All but the most recent chunk in the database should be finalised, i.e.
--   padded to the size of the chunk.
--
validateChunk ::
     forall m blk h.
     ( IOLike m
     , GetPrevHash blk
     , HasBinaryBlockInfo blk
     , DecodeDisk blk (Lazy.ByteString -> blk)
     , ConvertRawHash blk
     , HasCallStack
     )
  => ValidateEnv m blk h
  -> ShouldBeFinalised
  -> ChunkNo
  -> Maybe (ChainHash blk)
     -- ^ The hash of the last block of the previous chunk. 'Nothing' if
     -- unknown. When this is the first chunk, it should be 'Just Origin'.
  -> Tracer m (TraceChunkValidation blk ())
  -> ExceptT () m (Maybe (Tip blk))
     -- ^ When non-empty, the 'Tip' corresponds to the last valid block in the
     -- chunk.
     --
     -- When the chunk file is missing or when we should truncate starting from
     -- this chunk because it doesn't fit onto the previous one, @()@ is thrown.
     --
     -- Note that when an invalid block is detected, we don't throw, but we
     -- truncate the chunk file. When validating the chunk file after it, we
     -- would notice it doesn't fit anymore, and then throw.
validateChunk :: forall (m :: * -> *) blk h.
(IOLike m, GetPrevHash blk, HasBinaryBlockInfo blk,
 DecodeDisk blk (ByteString -> blk), ConvertRawHash blk,
 HasCallStack) =>
ValidateEnv m blk h
-> ShouldBeFinalised
-> ChunkNo
-> Maybe (ChainHash blk)
-> Tracer m (TraceChunkValidation blk ())
-> ExceptT () m (Maybe (Tip blk))
validateChunk ValidateEnv{Tracer m (TraceEvent blk)
HasFS m h
CodecConfig blk
ChunkInfo
CacheConfig
blk -> Bool
hasFS :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> HasFS m h
chunkInfo :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> ChunkInfo
tracer :: forall (m :: * -> *) blk h.
ValidateEnv m blk h -> Tracer m (TraceEvent blk)
cacheConfig :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> CacheConfig
codecConfig :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> CodecConfig blk
checkIntegrity :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> blk -> Bool
hasFS :: HasFS m h
chunkInfo :: ChunkInfo
tracer :: Tracer m (TraceEvent blk)
cacheConfig :: CacheConfig
codecConfig :: CodecConfig blk
checkIntegrity :: blk -> Bool
..} ShouldBeFinalised
shouldBeFinalised ChunkNo
chunk Maybe (ChainHash blk)
mbPrevHash Tracer m (TraceChunkValidation blk ())
validationTracer = do
    m () -> ExceptT () m ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT () m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT () m ()) -> m () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ Tracer m (TraceChunkValidation blk ())
-> TraceChunkValidation blk () -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChunkValidation blk ())
validationTracer (TraceChunkValidation blk () -> m ())
-> TraceChunkValidation blk () -> m ()
forall a b. (a -> b) -> a -> b
$ ChunkNo -> () -> TraceChunkValidation blk ()
forall blk validateTo.
ChunkNo -> validateTo -> TraceChunkValidation blk validateTo
StartedValidatingChunk ChunkNo
chunk ()
    Bool
chunkFileExists <- m Bool -> ExceptT () m Bool
forall (m :: * -> *) a. Monad m => m a -> ExceptT () m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Bool -> ExceptT () m Bool) -> m Bool -> ExceptT () m Bool
forall a b. (a -> b) -> a -> b
$ HasCallStack => FsPath -> m Bool
FsPath -> m Bool
doesFileExist FsPath
chunkFile
    Bool -> ExceptT () m () -> ExceptT () m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
chunkFileExists (ExceptT () m () -> ExceptT () m ())
-> ExceptT () m () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ do
      m () -> ExceptT () m ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT () m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT () m ()) -> m () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ Tracer m (TraceChunkValidation blk ())
-> TraceChunkValidation blk () -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChunkValidation blk ())
validationTracer (TraceChunkValidation blk () -> m ())
-> TraceChunkValidation blk () -> m ()
forall a b. (a -> b) -> a -> b
$ ChunkNo -> TraceChunkValidation blk ()
forall blk validateTo.
ChunkNo -> TraceChunkValidation blk validateTo
MissingChunkFile ChunkNo
chunk
      () -> ExceptT () m ()
forall a. () -> ExceptT () m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ()

    -- Read the entries from the secondary index file, if it exists.
    Bool
secondaryIndexFileExists  <- m Bool -> ExceptT () m Bool
forall (m :: * -> *) a. Monad m => m a -> ExceptT () m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Bool -> ExceptT () m Bool) -> m Bool -> ExceptT () m Bool
forall a b. (a -> b) -> a -> b
$ HasCallStack => FsPath -> m Bool
FsPath -> m Bool
doesFileExist FsPath
secondaryIndexFile
    [Entry blk]
entriesFromSecondaryIndex <- m [Entry blk] -> ExceptT () m [Entry blk]
forall (m :: * -> *) a. Monad m => m a -> ExceptT () m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [Entry blk] -> ExceptT () m [Entry blk])
-> m [Entry blk] -> ExceptT () m [Entry blk]
forall a b. (a -> b) -> a -> b
$ if Bool
secondaryIndexFileExists
      then (ImmutableDBError blk -> Maybe ())
-> m [WithBlockSize (Entry blk)]
-> m (Either () [WithBlockSize (Entry blk)])
forall e b a.
Exception e =>
(e -> Maybe b) -> m a -> m (Either b a)
forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust ImmutableDBError blk -> Maybe ()
isInvalidFileError
        -- Note the 'maxBound': it is used to calculate the block size for
        -- each entry, but we don't care about block sizes here, so we use
        -- some dummy value.
        (HasFS m h
-> SecondaryOffset
-> ChunkNo
-> (Entry blk -> Bool)
-> Word64
-> IsEBB
-> m [WithBlockSize (Entry blk)]
forall (m :: * -> *) blk h.
(HasCallStack, ConvertRawHash blk, MonadThrow m, StandardHash blk,
 Typeable blk) =>
HasFS m h
-> SecondaryOffset
-> ChunkNo
-> (Entry blk -> Bool)
-> Word64
-> IsEBB
-> m [WithBlockSize (Entry blk)]
Secondary.readAllEntries HasFS m h
hasFS SecondaryOffset
0 ChunkNo
chunk (Bool -> Entry blk -> Bool
forall a b. a -> b -> a
const Bool
False) Word64
forall a. Bounded a => a
maxBound IsEBB
IsEBB) m (Either () [WithBlockSize (Entry blk)])
-> (Either () [WithBlockSize (Entry blk)] -> m [Entry blk])
-> m [Entry blk]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left ()
_                -> do
            Tracer m (TraceChunkValidation blk ())
-> TraceChunkValidation blk () -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChunkValidation blk ())
validationTracer (TraceChunkValidation blk () -> m ())
-> TraceChunkValidation blk () -> m ()
forall a b. (a -> b) -> a -> b
$ ChunkNo -> TraceChunkValidation blk ()
forall blk validateTo.
ChunkNo -> TraceChunkValidation blk validateTo
InvalidSecondaryIndex ChunkNo
chunk
            [Entry blk] -> m [Entry blk]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
          Right [WithBlockSize (Entry blk)]
entriesFromFile ->
            [Entry blk] -> m [Entry blk]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Entry blk] -> m [Entry blk]) -> [Entry blk] -> m [Entry blk]
forall a b. (a -> b) -> a -> b
$ [Entry blk] -> [Entry blk]
forall hash. [Entry hash] -> [Entry hash]
fixupEBB ((WithBlockSize (Entry blk) -> Entry blk)
-> [WithBlockSize (Entry blk)] -> [Entry blk]
forall a b. (a -> b) -> [a] -> [b]
map WithBlockSize (Entry blk) -> Entry blk
forall a. WithBlockSize a -> a
withoutBlockSize [WithBlockSize (Entry blk)]
entriesFromFile)
      else do
        Tracer m (TraceChunkValidation blk ())
-> TraceChunkValidation blk () -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChunkValidation blk ())
validationTracer (TraceChunkValidation blk () -> m ())
-> TraceChunkValidation blk () -> m ()
forall a b. (a -> b) -> a -> b
$ ChunkNo -> TraceChunkValidation blk ()
forall blk validateTo.
ChunkNo -> TraceChunkValidation blk validateTo
MissingSecondaryIndex ChunkNo
chunk
        [Entry blk] -> m [Entry blk]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []

    -- Parse the chunk file using the checksums from the secondary index file
    -- as input. If the checksums match, the parser doesn't have to do the
    -- expensive integrity check of a block.
    let expectedChecksums :: [CRC]
expectedChecksums = (Entry blk -> CRC) -> [Entry blk] -> [CRC]
forall a b. (a -> b) -> [a] -> [b]
map Entry blk -> CRC
forall blk. Entry blk -> CRC
Secondary.checksum [Entry blk]
entriesFromSecondaryIndex
    ([(BlockSummary blk, ChainHash blk)]
entriesWithPrevHashes, Maybe (ChunkFileError blk, Word64)
mbErr) <- m ([(BlockSummary blk, ChainHash blk)],
   Maybe (ChunkFileError blk, Word64))
-> ExceptT
     ()
     m
     ([(BlockSummary blk, ChainHash blk)],
      Maybe (ChunkFileError blk, Word64))
forall (m :: * -> *) a. Monad m => m a -> ExceptT () m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ([(BlockSummary blk, ChainHash blk)],
    Maybe (ChunkFileError blk, Word64))
 -> ExceptT
      ()
      m
      ([(BlockSummary blk, ChainHash blk)],
       Maybe (ChunkFileError blk, Word64)))
-> m ([(BlockSummary blk, ChainHash blk)],
      Maybe (ChunkFileError blk, Word64))
-> ExceptT
     ()
     m
     ([(BlockSummary blk, ChainHash blk)],
      Maybe (ChunkFileError blk, Word64))
forall a b. (a -> b) -> a -> b
$
        CodecConfig blk
-> HasFS m h
-> (blk -> Bool)
-> FsPath
-> [CRC]
-> (Stream
      (Of (BlockSummary blk, ChainHash blk))
      m
      (Maybe (ChunkFileError blk, Word64))
    -> m ([(BlockSummary blk, ChainHash blk)],
          Maybe (ChunkFileError blk, Word64)))
-> m ([(BlockSummary blk, ChainHash blk)],
      Maybe (ChunkFileError blk, Word64))
forall (m :: * -> *) blk h r.
(IOLike m, GetPrevHash blk, HasBinaryBlockInfo blk,
 DecodeDisk blk (ByteString -> blk)) =>
CodecConfig blk
-> HasFS m h
-> (blk -> Bool)
-> FsPath
-> [CRC]
-> (Stream
      (Of (BlockSummary blk, ChainHash blk))
      m
      (Maybe (ChunkFileError blk, Word64))
    -> m r)
-> m r
parseChunkFile
          CodecConfig blk
codecConfig
          HasFS m h
hasFS
          blk -> Bool
checkIntegrity
          FsPath
chunkFile
          [CRC]
expectedChecksums
          (\Stream
  (Of (BlockSummary blk, ChainHash blk))
  m
  (Maybe (ChunkFileError blk, Word64))
entries -> (\([(BlockSummary blk, ChainHash blk)]
es :> Maybe (ChunkFileError blk, Word64)
mbErr) -> ([(BlockSummary blk, ChainHash blk)]
es, Maybe (ChunkFileError blk, Word64)
mbErr)) (Of
   [(BlockSummary blk, ChainHash blk)]
   (Maybe (ChunkFileError blk, Word64))
 -> ([(BlockSummary blk, ChainHash blk)],
     Maybe (ChunkFileError blk, Word64)))
-> m (Of
        [(BlockSummary blk, ChainHash blk)]
        (Maybe (ChunkFileError blk, Word64)))
-> m ([(BlockSummary blk, ChainHash blk)],
      Maybe (ChunkFileError blk, Word64))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stream
  (Of (BlockSummary blk, ChainHash blk))
  m
  (Maybe (ChunkFileError blk, Word64))
-> m (Of
        [(BlockSummary blk, ChainHash blk)]
        (Maybe (ChunkFileError blk, Word64)))
forall (m :: * -> *) a r.
Monad m =>
Stream (Of a) m r -> m (Of [a] r)
S.toList Stream
  (Of (BlockSummary blk, ChainHash blk))
  m
  (Maybe (ChunkFileError blk, Word64))
entries)

    -- Check whether the first block of this chunk fits onto the last block of
    -- the previous chunk.
    case [(BlockSummary blk, ChainHash blk)]
entriesWithPrevHashes of
      (BlockSummary blk
_, ChainHash blk
actualPrevHash) : [(BlockSummary blk, ChainHash blk)]
_
        | Just ChainHash blk
expectedPrevHash <- Maybe (ChainHash blk)
mbPrevHash
        , ChainHash blk
expectedPrevHash ChainHash blk -> ChainHash blk -> Bool
forall a. Eq a => a -> a -> Bool
/= ChainHash blk
actualPrevHash
          -- The previous hash of the first block in the chunk does not match
          -- the hash of the last block of the previous chunk. There must be a
          -- gap. This chunk should be truncated.
        -> do
          m () -> ExceptT () m ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT () m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT () m ()) -> m () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer (TraceEvent blk -> m ()) -> TraceEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ ChainHash blk -> ChainHash blk -> TraceEvent blk
forall blk. ChainHash blk -> ChainHash blk -> TraceEvent blk
ChunkFileDoesntFit ChainHash blk
expectedPrevHash ChainHash blk
actualPrevHash
          () -> ExceptT () m ()
forall a. () -> ExceptT () m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ()
      [(BlockSummary blk, ChainHash blk)]
_ -> () -> ExceptT () m ()
forall a. a -> ExceptT () m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    m (Maybe (Tip blk)) -> ExceptT () m (Maybe (Tip blk))
forall (m :: * -> *) a. Monad m => m a -> ExceptT () m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe (Tip blk)) -> ExceptT () m (Maybe (Tip blk)))
-> m (Maybe (Tip blk)) -> ExceptT () m (Maybe (Tip blk))
forall a b. (a -> b) -> a -> b
$ do

      -- If the parser returneds a deserialisation error, truncate the chunk
      -- file. Don't truncate the database just yet, because the
      -- deserialisation error may be due to some extra random bytes that
      -- shouldn't have been there in the first place.
      Maybe (ChunkFileError blk, Word64)
-> ((ChunkFileError blk, Word64) -> m ()) -> m ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe (ChunkFileError blk, Word64)
mbErr (((ChunkFileError blk, Word64) -> m ()) -> m ())
-> ((ChunkFileError blk, Word64) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(ChunkFileError blk
parseErr, Word64
endOfLastValidBlock) -> do
        Tracer m (TraceChunkValidation blk ())
-> TraceChunkValidation blk () -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChunkValidation blk ())
validationTracer (TraceChunkValidation blk () -> m ())
-> TraceChunkValidation blk () -> m ()
forall a b. (a -> b) -> a -> b
$ ChunkNo -> ChunkFileError blk -> TraceChunkValidation blk ()
forall blk validateTo.
ChunkNo
-> ChunkFileError blk -> TraceChunkValidation blk validateTo
InvalidChunkFile ChunkNo
chunk ChunkFileError blk
parseErr
        HasFS m h -> FsPath -> OpenMode -> (Handle h -> m ()) -> m ()
forall (m :: * -> *) h a.
(HasCallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS m h
hasFS FsPath
chunkFile (AllowExisting -> OpenMode
AppendMode AllowExisting
AllowExisting) ((Handle h -> m ()) -> m ()) -> (Handle h -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Handle h
eHnd ->
          HasCallStack => Handle h -> Word64 -> m ()
Handle h -> Word64 -> m ()
hTruncate Handle h
eHnd Word64
endOfLastValidBlock

      -- If the secondary index file is missing, parsing it failed, or it does
      -- not match the entries from the chunk file, overwrite it using those
      -- (truncate first).
      let summary :: [BlockSummary blk]
summary = ((BlockSummary blk, ChainHash blk) -> BlockSummary blk)
-> [(BlockSummary blk, ChainHash blk)] -> [BlockSummary blk]
forall a b. (a -> b) -> [a] -> [b]
map (BlockSummary blk, ChainHash blk) -> BlockSummary blk
forall a b. (a, b) -> a
fst [(BlockSummary blk, ChainHash blk)]
entriesWithPrevHashes
          entries :: [Entry blk]
entries = (BlockSummary blk -> Entry blk)
-> [BlockSummary blk] -> [Entry blk]
forall a b. (a -> b) -> [a] -> [b]
map BlockSummary blk -> Entry blk
forall blk. BlockSummary blk -> Entry blk
summaryEntry [BlockSummary blk]
summary
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Entry blk]
entriesFromSecondaryIndex [Entry blk] -> [Entry blk] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Entry blk]
entries Bool -> Bool -> Bool
||
            Bool -> Bool
not Bool
secondaryIndexFileExists) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        Tracer m (TraceChunkValidation blk ())
-> TraceChunkValidation blk () -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChunkValidation blk ())
validationTracer (TraceChunkValidation blk () -> m ())
-> TraceChunkValidation blk () -> m ()
forall a b. (a -> b) -> a -> b
$ ChunkNo -> TraceChunkValidation blk ()
forall blk validateTo.
ChunkNo -> TraceChunkValidation blk validateTo
RewriteSecondaryIndex ChunkNo
chunk
        HasFS m h -> ChunkNo -> [Entry blk] -> m ()
forall (m :: * -> *) blk h.
(HasCallStack, ConvertRawHash blk, MonadThrow m) =>
HasFS m h -> ChunkNo -> [Entry blk] -> m ()
Secondary.writeAllEntries HasFS m h
hasFS ChunkNo
chunk [Entry blk]
entries

      -- Reconstruct the primary index from the 'Secondary.Entry's.
      --
      -- Read the primary index file, if it is missing, parsing fails, or it
      -- does not match the reconstructed primary index, overwrite it using
      -- the reconstructed index (truncate first).
      let primaryIndex :: PrimaryIndex
primaryIndex = Proxy blk
-> ChunkInfo
-> ShouldBeFinalised
-> ChunkNo
-> [BlockOrEBB]
-> PrimaryIndex
forall blk.
(ConvertRawHash blk, HasCallStack) =>
Proxy blk
-> ChunkInfo
-> ShouldBeFinalised
-> ChunkNo
-> [BlockOrEBB]
-> PrimaryIndex
reconstructPrimaryIndex
                           (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)
                           ChunkInfo
chunkInfo
                           ShouldBeFinalised
shouldBeFinalised
                           ChunkNo
chunk
                           ((Entry blk -> BlockOrEBB) -> [Entry blk] -> [BlockOrEBB]
forall a b. (a -> b) -> [a] -> [b]
map Entry blk -> BlockOrEBB
forall blk. Entry blk -> BlockOrEBB
Secondary.blockOrEBB [Entry blk]
entries)
      Bool
primaryIndexFileExists  <- HasCallStack => FsPath -> m Bool
FsPath -> m Bool
doesFileExist FsPath
primaryIndexFile
      Bool
primaryIndexFileMatches <- if Bool
primaryIndexFileExists
        then (ImmutableDBError blk -> Maybe ())
-> m PrimaryIndex -> m (Either () PrimaryIndex)
forall e b a.
Exception e =>
(e -> Maybe b) -> m a -> m (Either b a)
forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust ImmutableDBError blk -> Maybe ()
isInvalidFileError (Proxy blk -> HasFS m h -> ChunkNo -> m PrimaryIndex
forall blk (m :: * -> *) h.
(HasCallStack, MonadThrow m, StandardHash blk, Typeable blk) =>
Proxy blk -> HasFS m h -> ChunkNo -> m PrimaryIndex
Primary.load (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) HasFS m h
hasFS ChunkNo
chunk) m (Either () PrimaryIndex)
-> (Either () PrimaryIndex -> m Bool) -> m Bool
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left ()                    -> do
            Tracer m (TraceChunkValidation blk ())
-> TraceChunkValidation blk () -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChunkValidation blk ())
validationTracer (TraceChunkValidation blk () -> m ())
-> TraceChunkValidation blk () -> m ()
forall a b. (a -> b) -> a -> b
$ ChunkNo -> TraceChunkValidation blk ()
forall blk validateTo.
ChunkNo -> TraceChunkValidation blk validateTo
InvalidPrimaryIndex ChunkNo
chunk
            Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
          Right PrimaryIndex
primaryIndexFromFile ->
            Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ PrimaryIndex
primaryIndexFromFile PrimaryIndex -> PrimaryIndex -> Bool
forall a. Eq a => a -> a -> Bool
== PrimaryIndex
primaryIndex
        else do
          Tracer m (TraceChunkValidation blk ())
-> TraceChunkValidation blk () -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChunkValidation blk ())
validationTracer (TraceChunkValidation blk () -> m ())
-> TraceChunkValidation blk () -> m ()
forall a b. (a -> b) -> a -> b
$ ChunkNo -> TraceChunkValidation blk ()
forall blk validateTo.
ChunkNo -> TraceChunkValidation blk validateTo
MissingPrimaryIndex ChunkNo
chunk
          Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
primaryIndexFileMatches (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        Tracer m (TraceChunkValidation blk ())
-> TraceChunkValidation blk () -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChunkValidation blk ())
validationTracer (TraceChunkValidation blk () -> m ())
-> TraceChunkValidation blk () -> m ()
forall a b. (a -> b) -> a -> b
$ ChunkNo -> TraceChunkValidation blk ()
forall blk validateTo.
ChunkNo -> TraceChunkValidation blk validateTo
RewritePrimaryIndex ChunkNo
chunk
        HasFS m h -> ChunkNo -> PrimaryIndex -> m ()
forall (m :: * -> *) h.
(HasCallStack, MonadThrow m) =>
HasFS m h -> ChunkNo -> PrimaryIndex -> m ()
Primary.write HasFS m h
hasFS ChunkNo
chunk PrimaryIndex
primaryIndex

      Maybe (Tip blk) -> m (Maybe (Tip blk))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Tip blk) -> m (Maybe (Tip blk)))
-> Maybe (Tip blk) -> m (Maybe (Tip blk))
forall a b. (a -> b) -> a -> b
$ BlockSummary blk -> Tip blk
summaryToTipInfo (BlockSummary blk -> Tip blk)
-> Maybe (BlockSummary blk) -> Maybe (Tip blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BlockSummary blk] -> Maybe (BlockSummary blk)
forall a. [a] -> Maybe a
lastMaybe [BlockSummary blk]
summary
  where
    chunkFile :: FsPath
chunkFile          = ChunkNo -> FsPath
fsPathChunkFile          ChunkNo
chunk
    primaryIndexFile :: FsPath
primaryIndexFile   = ChunkNo -> FsPath
fsPathPrimaryIndexFile   ChunkNo
chunk
    secondaryIndexFile :: FsPath
secondaryIndexFile = ChunkNo -> FsPath
fsPathSecondaryIndexFile ChunkNo
chunk

    HasFS { HasCallStack => Handle h -> Word64 -> m ()
hTruncate :: HasCallStack => Handle h -> Word64 -> m ()
hTruncate :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> Word64 -> m ()
hTruncate, HasCallStack => FsPath -> m Bool
doesFileExist :: HasCallStack => FsPath -> m Bool
doesFileExist :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesFileExist } = HasFS m h
hasFS

    summaryToTipInfo :: BlockSummary blk -> Tip blk
    summaryToTipInfo :: BlockSummary blk -> Tip blk
summaryToTipInfo BlockSummary {BlockNo
SlotNo
Entry blk
summaryEntry :: forall blk. BlockSummary blk -> Entry blk
summaryEntry :: Entry blk
summaryBlockNo :: BlockNo
summarySlotNo :: SlotNo
summaryBlockNo :: forall blk. BlockSummary blk -> BlockNo
summarySlotNo :: forall blk. BlockSummary blk -> SlotNo
..} = Tip {
          tipSlotNo :: SlotNo
tipSlotNo  = SlotNo
summarySlotNo
        , tipIsEBB :: IsEBB
tipIsEBB   = BlockOrEBB -> IsEBB
isBlockOrEBB (BlockOrEBB -> IsEBB) -> BlockOrEBB -> IsEBB
forall a b. (a -> b) -> a -> b
$ Entry blk -> BlockOrEBB
forall blk. Entry blk -> BlockOrEBB
Secondary.blockOrEBB Entry blk
summaryEntry
        , tipBlockNo :: BlockNo
tipBlockNo = BlockNo
summaryBlockNo
        , tipHash :: HeaderHash blk
tipHash    = Entry blk -> HeaderHash blk
forall blk. Entry blk -> HeaderHash blk
Secondary.headerHash Entry blk
summaryEntry
        }

    -- | 'InvalidFileError' is the only error that can be thrown while loading
    -- a primary or a secondary index file
    isInvalidFileError :: ImmutableDBError blk -> Maybe ()
    isInvalidFileError :: ImmutableDBError blk -> Maybe ()
isInvalidFileError = \case
      UnexpectedFailure (InvalidFileError {}) -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
      ImmutableDBError blk
_                                       -> Maybe ()
forall a. Maybe a
Nothing

    -- | When reading the entries from the secondary index file, we need to
    -- pass in a value of type 'IsEBB' so we know whether the first entry
    -- corresponds to an EBB or a regular block. We need this information to
    -- correctly interpret the deserialised 'Word64' as a 'BlockOrEBB': if
    -- it's an EBB, it's the 'EpochNo' ('Word64'), if it's a regular block,
    -- it's a 'SlotNo' ('Word64').
    --
    -- However, at the point we are reading the secondary index file, we don't
    -- yet know whether the first block will be an EBB or a regular block. We
    -- will find that out when we read the actual block from the chunk file.
    --
    -- Fortunately, we can make a /very/ good guess: if the 'Word64' of the
    -- 'BlockOrEBB' matches the chunk number, it is almost certainly an EBB,
    -- as the slot numbers increase @10k@ times faster than chunk numbers
    -- (remember that for EBBs, chunk numbers and epoch numbers must line up).
    -- Property: for every chunk @e > 0@, for all slot numbers @s@ in chunk
    -- @e@ we have @s > e@. The only exception is chunk 0, which contains a
    -- slot number 0. From this follows that it's an EBB if and only if the
    -- 'Word64' matches the chunk number.
    --
    -- E.g., the first slot number in chunk 1 will be 21600 if @k = 2160@. We
    -- could only make the wrong guess in the first very first chunk, i.e.,
    -- chunk 0, as the first slot number is also 0. However, we know that the
    -- real blockchain starts with an EBB, so even in that case we're fine.
    --
    -- If the chunk size were 1, then we would make the wrong guess for each
    -- chunk that contains an EBB, which is a rather unrealistic scenario.
    --
    -- Note that even making the wrong guess is not a problem. The (CRC)
    -- checksums are the only thing we extract from the secondary index file.
    -- These are passed to the 'ChunkFileParser'. We then reconstruct the
    -- secondary index using the output of the 'ChunkFileParser'. If that
    -- output doesn't match the parsed secondary index file, we will overwrite
    -- the secondary index file.
    --
    -- So the only thing that wouldn't go according to plan is that we will
    -- needlessly overwrite the secondary index file.
    fixupEBB :: forall hash. [Secondary.Entry hash] -> [Secondary.Entry hash]
    fixupEBB :: forall hash. [Entry hash] -> [Entry hash]
fixupEBB = \case
      entry :: Entry hash
entry@Secondary.Entry { blockOrEBB :: forall blk. Entry blk -> BlockOrEBB
blockOrEBB = EBB EpochNo
epoch' }:[Entry hash]
rest
        | let chunk' :: ChunkNo
chunk' = EpochNo -> ChunkNo
unsafeEpochNoToChunkNo EpochNo
epoch'
        , ChunkNo
chunk' ChunkNo -> ChunkNo -> Bool
forall a. Eq a => a -> a -> Bool
/= ChunkNo
chunk
        -> Entry hash
entry { Secondary.blockOrEBB = Block (SlotNo (unChunkNo chunk')) }Entry hash -> [Entry hash] -> [Entry hash]
forall a. a -> [a] -> [a]
:[Entry hash]
rest
      [Entry hash]
entries -> [Entry hash]
entries

-- | Reconstruct a 'PrimaryIndex' based on a list of 'Secondary.Entry's.
reconstructPrimaryIndex ::
     forall blk. (ConvertRawHash blk, HasCallStack)
  => Proxy blk
  -> ChunkInfo
  -> ShouldBeFinalised
  -> ChunkNo
  -> [BlockOrEBB]
  -> PrimaryIndex
reconstructPrimaryIndex :: forall blk.
(ConvertRawHash blk, HasCallStack) =>
Proxy blk
-> ChunkInfo
-> ShouldBeFinalised
-> ChunkNo
-> [BlockOrEBB]
-> PrimaryIndex
reconstructPrimaryIndex Proxy blk
pb ChunkInfo
chunkInfo ShouldBeFinalised
shouldBeFinalised ChunkNo
chunk [BlockOrEBB]
blockOrEBBs =
    PrimaryIndex -> Maybe PrimaryIndex -> PrimaryIndex
forall a. a -> Maybe a -> a
fromMaybe (String -> PrimaryIndex
forall a. HasCallStack => String -> a
error String
nonIncreasing) (Maybe PrimaryIndex -> PrimaryIndex)
-> Maybe PrimaryIndex -> PrimaryIndex
forall a b. (a -> b) -> a -> b
$
      ChunkNo -> [SecondaryOffset] -> Maybe PrimaryIndex
Primary.mk ChunkNo
chunk ([SecondaryOffset] -> Maybe PrimaryIndex)
-> ([SecondaryOffset] -> [SecondaryOffset])
-> [SecondaryOffset]
-> Maybe PrimaryIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SecondaryOffset
0SecondaryOffset -> [SecondaryOffset] -> [SecondaryOffset]
forall a. a -> [a] -> [a]
:) ([SecondaryOffset] -> Maybe PrimaryIndex)
-> [SecondaryOffset] -> Maybe PrimaryIndex
forall a b. (a -> b) -> a -> b
$
        HasCallStack =>
NextRelativeSlot
-> SecondaryOffset -> [RelativeSlot] -> [SecondaryOffset]
NextRelativeSlot
-> SecondaryOffset -> [RelativeSlot] -> [SecondaryOffset]
go (RelativeSlot -> NextRelativeSlot
NextRelativeSlot (ChunkInfo -> ChunkNo -> RelativeSlot
firstBlockOrEBB ChunkInfo
chunkInfo ChunkNo
chunk)) SecondaryOffset
0 ([RelativeSlot] -> [SecondaryOffset])
-> [RelativeSlot] -> [SecondaryOffset]
forall a b. (a -> b) -> a -> b
$
          (BlockOrEBB -> RelativeSlot) -> [BlockOrEBB] -> [RelativeSlot]
forall a b. (a -> b) -> [a] -> [b]
map (ChunkSlot -> RelativeSlot
chunkRelative (ChunkSlot -> RelativeSlot)
-> (BlockOrEBB -> ChunkSlot) -> BlockOrEBB -> RelativeSlot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChunkInfo -> BlockOrEBB -> ChunkSlot
chunkSlotForBlockOrEBB ChunkInfo
chunkInfo) [BlockOrEBB]
blockOrEBBs
  where
    nonIncreasing :: String
    nonIncreasing :: String
nonIncreasing = String
"blocks have non-increasing slot numbers"

    go :: HasCallStack
       => NextRelativeSlot
       -> SecondaryOffset
       -> [RelativeSlot]
       -> [SecondaryOffset]
    go :: HasCallStack =>
NextRelativeSlot
-> SecondaryOffset -> [RelativeSlot] -> [SecondaryOffset]
go NextRelativeSlot
expected SecondaryOffset
lastSecondaryOffset [RelativeSlot]
relSlots =
        case (NextRelativeSlot
expected, [RelativeSlot]
relSlots) of
          (NextRelativeSlot
_, []) ->
            case ShouldBeFinalised
shouldBeFinalised of
              ShouldBeFinalised
ShouldNotBeFinalised -> []
              ShouldBeFinalised
ShouldBeFinalised    -> ChunkInfo
-> ChunkNo
-> NextRelativeSlot
-> SecondaryOffset
-> [SecondaryOffset]
Primary.backfillChunk
                                        ChunkInfo
chunkInfo
                                        ChunkNo
chunk
                                        NextRelativeSlot
expected
                                        SecondaryOffset
lastSecondaryOffset
          (NextRelativeSlot
NoMoreRelativeSlots, [RelativeSlot]
_) ->
            -- Assumption: when we validate the chunk file, we check its size
            String -> [SecondaryOffset]
forall a. HasCallStack => String -> a
error String
"reconstructPrimaryIndex: too many entries"
          (NextRelativeSlot RelativeSlot
nextExpectedRelSlot, RelativeSlot
relSlot:[RelativeSlot]
relSlots') ->
            if HasCallStack => RelativeSlot -> RelativeSlot -> Ordering
RelativeSlot -> RelativeSlot -> Ordering
compareRelativeSlot RelativeSlot
relSlot RelativeSlot
nextExpectedRelSlot Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT then
              String -> [SecondaryOffset]
forall a. HasCallStack => String -> a
error String
nonIncreasing
            else
              let backfilled :: [SecondaryOffset]
backfilled      = RelativeSlot
-> RelativeSlot -> SecondaryOffset -> [SecondaryOffset]
Primary.backfill
                                      RelativeSlot
relSlot
                                      RelativeSlot
nextExpectedRelSlot
                                      SecondaryOffset
lastSecondaryOffset
                  secondaryOffset :: SecondaryOffset
secondaryOffset = SecondaryOffset
lastSecondaryOffset
                                  SecondaryOffset -> SecondaryOffset -> SecondaryOffset
forall a. Num a => a -> a -> a
+ Proxy blk -> SecondaryOffset
forall blk. ConvertRawHash blk => Proxy blk -> SecondaryOffset
Secondary.entrySize Proxy blk
pb
              in [SecondaryOffset]
backfilled [SecondaryOffset] -> [SecondaryOffset] -> [SecondaryOffset]
forall a. [a] -> [a] -> [a]
++ SecondaryOffset
secondaryOffset
               SecondaryOffset -> [SecondaryOffset] -> [SecondaryOffset]
forall a. a -> [a] -> [a]
: HasCallStack =>
NextRelativeSlot
-> SecondaryOffset -> [RelativeSlot] -> [SecondaryOffset]
NextRelativeSlot
-> SecondaryOffset -> [RelativeSlot] -> [SecondaryOffset]
go (HasCallStack => RelativeSlot -> NextRelativeSlot
RelativeSlot -> NextRelativeSlot
nextRelativeSlot RelativeSlot
relSlot) SecondaryOffset
secondaryOffset [RelativeSlot]
relSlots'


{------------------------------------------------------------------------------
  Migration
------------------------------------------------------------------------------}

-- | Migrate the files in the database to the latest version.
--
-- We always migrate the database to the latest version before opening it. If
-- a migration was unsuccessful, an error is thrown and the database is not
-- opened. User intervention will be needed before the database can be
-- reopened, as without it, the same error will be thrown when reopening the
-- database the next time.
--
-- For example, when during a migration we have to rename a file A to B, but
-- we don't have permissions to do so, we require user intervention.
--
-- We have the following versions, from current to oldest:
--
-- * Current version:
--
--   - Chunk files are named "XXXXX.chunk" where "XXXXX" is the chunk/epoch
--     number padded with zeroes to five decimals. A chunk file stores the
--     blocks in that chunk sequentially. Empty slots are skipped.
--
--   - Primary index files are named "XXXXX.primary". See 'PrimaryIndex' for
--     more information.
--
--   - Secondary index files are named "XXXXX.secondary". See
--     'Secondary.Entry' for more information.
--
-- * The only difference with the version after it was that chunk files were
--   named "XXXXX.epoch" instead of "XXXXX.chunk". The contents of all files
--   remain identical because we chose the chunk size to be equal to the Byron
--   epoch size and allowed EBBs in the chunk.
--
-- We don't include versions before the first release, as we don't have to
-- migrate from them.
--
-- Note that primary index files also contain a version number, but since the
-- binary format hasn't changed yet, this version number hasn't been changed
-- yet.
--
-- Implementation note: as currently the sole migration we need to be able to
-- perform only requires renaming files, we keep it simple for now.
migrate :: (IOLike m, HasCallStack) => ValidateEnv m blk h -> m ()
migrate :: forall (m :: * -> *) blk h.
(IOLike m, HasCallStack) =>
ValidateEnv m blk h -> m ()
migrate ValidateEnv { HasFS m h
hasFS :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> HasFS m h
hasFS :: HasFS m h
hasFS, Tracer m (TraceEvent blk)
tracer :: forall (m :: * -> *) blk h.
ValidateEnv m blk h -> Tracer m (TraceEvent blk)
tracer :: Tracer m (TraceEvent blk)
tracer } = do
    Set String
filesInDBFolder <- HasCallStack => FsPath -> m (Set String)
FsPath -> m (Set String)
listDirectory ([String] -> FsPath
mkFsPath [])
    -- Any old "XXXXX.epoch" files
    let epochFileChunkNos :: [(FsPath, ChunkNo)]
        epochFileChunkNos :: [(FsPath, ChunkNo)]
epochFileChunkNos =
          (String -> Maybe (FsPath, ChunkNo))
-> [String] -> [(FsPath, ChunkNo)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
            (\String
file -> ([String] -> FsPath
mkFsPath [String
file],) (ChunkNo -> (FsPath, ChunkNo))
-> Maybe ChunkNo -> Maybe (FsPath, ChunkNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe ChunkNo
isEpochFile String
file)
            (Set String -> [String]
forall a. Set a -> [a]
Set.toAscList Set String
filesInDBFolder)

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(FsPath, ChunkNo)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FsPath, ChunkNo)]
epochFileChunkNos) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer (TraceEvent blk -> m ()) -> TraceEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> TraceEvent blk
forall blk. Text -> TraceEvent blk
Migrating Text
".epoch files to .chunk files"
      [(FsPath, ChunkNo)] -> ((FsPath, ChunkNo) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(FsPath, ChunkNo)]
epochFileChunkNos (((FsPath, ChunkNo) -> m ()) -> m ())
-> ((FsPath, ChunkNo) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(FsPath
epochFile, ChunkNo
chunk) ->
        HasCallStack => FsPath -> FsPath -> m ()
FsPath -> FsPath -> m ()
renameFile FsPath
epochFile (ChunkNo -> FsPath
fsPathChunkFile ChunkNo
chunk)
  where
    HasFS { HasCallStack => FsPath -> m (Set String)
listDirectory :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m (Set String)
listDirectory :: HasCallStack => FsPath -> m (Set String)
listDirectory, HasCallStack => FsPath -> FsPath -> m ()
renameFile :: HasCallStack => FsPath -> FsPath -> m ()
renameFile :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> FsPath -> m ()
renameFile } = HasFS m h
hasFS

    isEpochFile :: String -> Maybe ChunkNo
    isEpochFile :: String -> Maybe ChunkNo
isEpochFile String
s = case String -> Maybe (String, ChunkNo)
parseDBFile String
s of
      Just (String
prefix, ChunkNo
chunk)
        | String
prefix String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"epoch"
        -> ChunkNo -> Maybe ChunkNo
forall a. a -> Maybe a
Just ChunkNo
chunk
      Maybe (String, ChunkNo)
_ -> Maybe ChunkNo
forall a. Maybe a
Nothing