{-# 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.ResourceRegistry
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 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
  (chunk, 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 <-
    lift $
      cachedIndex
        hasFS
        registry
        cacheTracer
        cacheConfig
        chunkInfo
        chunk
  case 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

  filesInDBFolder <- HasCallStack => FsPath -> m (Set String)
FsPath -> m (Set String)
listDirectory ([String] -> FsPath
mkFsPath [])
  let (chunkFiles, _, _) = dbFilesOnDisk filesInDBFolder
  case Set.lookupMax 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 ()) ->
  -- | Most recent chunk on disk
  ChunkNo ->
  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 ()) ->
  -- | Most recent chunk on disk, the chunk to validate
  ChunkNo ->
  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
  res <- ChunkNo -> m (ChunkNo, WithOrigin (Tip blk))
go ChunkNo
c
  traceWith validateTracer (ValidatedChunk c ())
  return 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 ->
  -- | The hash of the last block of the previous chunk. 'Nothing' if
  -- unknown. When this is the first chunk, it should be 'Just Origin'.
  Maybe (ChainHash blk) ->
  Tracer m (TraceChunkValidation 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.
  ExceptT () m (Maybe (Tip blk))
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 ()
  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
  unless chunkFileExists $ do
    lift $ traceWith validationTracer $ MissingChunkFile chunk
    throwError ()

  -- Read the entries from the secondary index file, if it exists.
  secondaryIndexFileExists <- lift $ doesFileExist secondaryIndexFile
  entriesFromSecondaryIndex <-
    lift $
      if secondaryIndexFileExists
        then
          tryJust
            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.
            (Secondary.readAllEntries hasFS 0 chunk (const False) maxBound IsEBB)
            >>= \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
          traceWith validationTracer $ MissingSecondaryIndex chunk
          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 = (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
  (entriesWithPrevHashes, mbErr) <-
    lift $
      parseChunkFile
        codecConfig
        hasFS
        checkIntegrity
        chunkFile
        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 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 ()

  lift $ 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.
    whenJust mbErr $ \(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, 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 = (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
    when
      ( entriesFromSecondaryIndex /= entries
          || not secondaryIndexFileExists
      )
      $ do
        traceWith validationTracer $ RewriteSecondaryIndex chunk
        Secondary.writeAllEntries hasFS chunk 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 =
          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)
    primaryIndexFileExists <- doesFileExist primaryIndexFile
    primaryIndexFileMatches <-
      if primaryIndexFileExists
        then
          tryJust isInvalidFileError (Primary.load (Proxy @blk) hasFS chunk) >>= \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
          traceWith validationTracer $ MissingPrimaryIndex chunk
          return False
    unless primaryIndexFileMatches $ do
      traceWith validationTracer $ RewritePrimaryIndex chunk
      Primary.write hasFS chunk primaryIndex

    return $ summaryToTipInfo <$> lastMaybe 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
summarySlotNo :: forall blk. BlockSummary blk -> SlotNo
summaryBlockNo :: forall blk. BlockSummary blk -> BlockNo
..} =
    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
0 SecondaryOffset -> [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
  filesInDBFolder <- HasCallStack => FsPath -> m (Set String)
FsPath -> m (Set String)
listDirectory ([String] -> FsPath
mkFsPath [])
  -- Any old "XXXXX.epoch" files
  let 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)

  unless (null epochFileChunkNos) $ do
    traceWith tracer $ Migrating ".epoch files to .chunk files"
    forM_ epochFileChunkNos $ \(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