{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE MultiWayIf          #-}
{-# 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, lift, runExceptT, throwError)
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           Streaming (Of (..))
import qualified Streaming.Prelude as S

import           Ouroboros.Consensus.Block hiding (hashSize)
import           Ouroboros.Consensus.Util (lastMaybe, whenJust)
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.ResourceRegistry

import           Ouroboros.Consensus.Storage.FS.API
import           Ouroboros.Consensus.Storage.FS.API.Types

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, SecondaryOffset)
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 (..))

-- | 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 {
      ValidateEnv m blk h -> HasFS m h
hasFS          :: !(HasFS m h)
    , ValidateEnv m blk h -> ChunkInfo
chunkInfo      :: !ChunkInfo
    , ValidateEnv m blk h -> Tracer m (TraceEvent blk)
tracer         :: !(Tracer m (TraceEvent blk))
    , ValidateEnv m blk h -> CacheConfig
cacheConfig    :: !Index.CacheConfig
    , ValidateEnv m blk h -> CodecConfig blk
codecConfig    :: !(CodecConfig blk)
    , 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 :: 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 (Proxy blk
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 (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 (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 (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 (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 :: HasFS m h
hasFS :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> HasFS m h
hasFS, Tracer m (TraceEvent blk)
tracer :: Tracer m (TraceEvent blk)
tracer :: forall (m :: * -> *) blk h.
ValidateEnv m blk h -> Tracer m (TraceEvent blk)
tracer, CacheConfig
cacheConfig :: CacheConfig
cacheConfig :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> CacheConfig
cacheConfig, ChunkInfo
chunkInfo :: ChunkInfo
chunkInfo :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> ChunkInfo
chunkInfo } = ValidateEnv m blk h
validateEnv
    cacheTracer :: Tracer m TraceCacheEvent
cacheTracer = (TraceCacheEvent -> TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m TraceCacheEvent
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> 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 :: ValidateEnv m blk h
-> ValidationPolicy -> m (ChunkNo, WithOrigin (Tip blk))
validate validateEnv :: ValidateEnv m blk h
validateEnv@ValidateEnv{ HasFS m h
hasFS :: HasFS m h
hasFS :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> HasFS m h
hasFS, Tracer m (TraceEvent blk)
tracer :: Tracer m (TraceEvent blk)
tracer :: forall (m :: * -> *) blk h.
ValidateEnv m blk h -> 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 (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 :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m (Set String)
listDirectory :: 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 (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> 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 (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 :: 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 :: HasFS m h
hasFS :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> HasFS m h
hasFS, ChunkInfo
chunkInfo :: ChunkInfo
chunkInfo :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> 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 b. 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 (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 b. 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 (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 (Proxy blk
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 :: 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 :: HasFS m h
hasFS :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> 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 (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 (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 (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 (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
showList :: [ShouldBeFinalised] -> ShowS
$cshowList :: [ShouldBeFinalised] -> ShowS
show :: ShouldBeFinalised -> String
$cshow :: ShouldBeFinalised -> String
showsPrec :: Int -> ShouldBeFinalised -> ShowS
$cshowsPrec :: Int -> 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 :: 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
checkIntegrity :: blk -> Bool
codecConfig :: CodecConfig blk
cacheConfig :: CacheConfig
tracer :: Tracer m (TraceEvent blk)
chunkInfo :: ChunkInfo
hasFS :: HasFS m h
checkIntegrity :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> blk -> Bool
codecConfig :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> CodecConfig blk
cacheConfig :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> CacheConfig
tracer :: forall (m :: * -> *) blk h.
ValidateEnv m blk h -> Tracer m (TraceEvent blk)
chunkInfo :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> ChunkInfo
hasFS :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> HasFS m h
..} ShouldBeFinalised
shouldBeFinalised ChunkNo
chunk Maybe (ChainHash blk)
mbPrevHash Tracer m (TraceChunkValidation blk ())
validationTracer = do
    m () -> ExceptT () m ()
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 (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 (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 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 (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 (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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return []
          Right [WithBlockSize (Entry blk)]
entriesFromFile ->
            [Entry blk] -> m [Entry blk]
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 (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 (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 (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 e (m :: * -> *) a. MonadError e m => e -> m a
throwError ()
      [(BlockSummary blk, ChainHash blk)]
_ -> () -> ExceptT () m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    m (Maybe (Tip blk)) -> ExceptT () m (Maybe (Tip blk))
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
                           (Proxy blk
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 (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 (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk) HasFS m h
hasFS ChunkNo
chunk) m (Either () PrimaryIndex)
-> (Either () PrimaryIndex -> m Bool) -> m Bool
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 (m :: * -> *) a. Monad m => a -> m a
return Bool
False
          Right PrimaryIndex
primaryIndexFromFile ->
            Bool -> m Bool
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 (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 (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 :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> Word64 -> m ()
hTruncate :: HasCallStack => Handle h -> Word64 -> m ()
hTruncate, HasCallStack => FsPath -> m Bool
doesFileExist :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesFileExist :: 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
summarySlotNo :: forall blk. BlockSummary blk -> SlotNo
summaryBlockNo :: forall blk. BlockSummary blk -> BlockNo
summarySlotNo :: SlotNo
summaryBlockNo :: BlockNo
summaryEntry :: Entry blk
summaryEntry :: forall blk. BlockSummary blk -> Entry blk
..} = Tip :: forall blk. SlotNo -> IsEBB -> BlockNo -> HeaderHash blk -> Tip blk
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 :: [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 { blockOrEBB :: BlockOrEBB
Secondary.blockOrEBB = SlotNo -> BlockOrEBB
Block (Word64 -> SlotNo
SlotNo (ChunkNo -> Word64
unChunkNo ChunkNo
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 :: 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 :: 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 :: ValidateEnv m blk h -> m ()
migrate ValidateEnv { HasFS m h
hasFS :: HasFS m h
hasFS :: forall (m :: * -> *) blk h. ValidateEnv m blk h -> HasFS m h
hasFS, Tracer m (TraceEvent blk)
tracer :: Tracer m (TraceEvent blk)
tracer :: forall (m :: * -> *) blk h.
ValidateEnv m blk h -> 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 (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 :: HasCallStack => FsPath -> m (Set String)
listDirectory :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m (Set String)
listDirectory, HasCallStack => FsPath -> FsPath -> m ()
renameFile :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> FsPath -> m ()
renameFile :: 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