{-# LANGUAGE ConstraintKinds           #-}
{-# LANGUAGE DeriveAnyClass            #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE LambdaCase                #-}
{-# LANGUAGE MultiWayIf                #-}
{-# LANGUAGE NamedFieldPuns            #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE QuantifiedConstraints     #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE RecordWildCards           #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TupleSections             #-}
{-# LANGUAGE TypeApplications          #-}
-- | Volatile on-disk database of blocks
--
-- = Logic
--
-- The VolatileDB is a key-value store of blocks indexed by their hashes. It is
-- parameterised by the block type @blk@.
--
-- The \"volatile\" in the name refers to the fact that the blocks stored in it
-- make up the /volatile/ part of the chain, i.e., the last @k@ blocks of the
-- chain, which can still be rolled back. Not only the last @k@ blocks of the
-- current chain are stored in this database, but also blocks of forks which we
-- have switched from or will switch to.
--
-- The VolatileDB appends new blocks sequentially to a file. When
-- 'volMaxBlocksPerFile' are stored in the current file, a new file is started.
--
-- The VolatileDB provides four main operations:
--
-- 1. Adding blocks with 'putBlock'
-- 2. Get blocks or information about them with 'getBlockComponent'
-- 3. Accessing the in-memory indices using 'getBlockInfo' and
--   'filterByPredecessor'
-- 4. Garbage collecting blocks older than a given slot using 'garbageCollect'
--
-- Garbage collection will only delete a file from the VolatileDB when all
-- blocks in it have a slot older than the one passed to 'garbageCollect'.
--
-- = Errors
--
-- When an exception occurs while modifying the VolatileDB, we close the
-- database as a safety measure, e.g., in case a file could not be written to
-- disk, as we can no longer make sure the in-memory indices match what's stored
-- on the file system. When reopening, we validate the blocks stored in the file
-- system and reconstruct the in-memory indices.
--
-- NOTE: this means that when a thread modifying the VolatileDB is killed, the
-- database will be closed. This is an intentional choice to simplify things.
--
-- The in-memory indices can always be reconstructed from the file system.
-- This is important, as we must be resilient against unexpected shutdowns,
-- power losses, etc.
--
-- We achieve this by only performing basic operations on the VolatileDB:
-- * 'putBlock' only appends a new block to a file. Losing an update means we
--   only lose a block, which is not a problem, it can be redownloaded.
-- * 'garbageCollect' only deletes entire files.
-- * There is no operation that modifies a file in-place. This means we do not
--   have to keep any rollback journals to make sure we are safe in case of
--   unexpected shutdowns.
--
-- We only throw 'VolatileDBError'. File-system errors are caught, wrapped in a
-- 'VolatileDBError', and rethrown. We make sure that all calls to 'HasFS'
-- functions are properly wrapped. This wrapping is automatically done when
-- inside the scope of 'modifyOpenState' and 'withOpenState'. Otherwise, we use
-- 'wrapFsError'.
--
-- = Concurrency
--
-- A single folder should only be used by a single VolatileDB. Naturally, a
-- VolatileDB can be accessed concurrently by multiple threads.
--
-- = File-system layout:
--
-- The on-disk representation is as follows:
--
-- > dbFolder/
-- >   blocks-0.dat
-- >   blocks-1.dat
-- >   ...
--
-- Files not fitting the naming scheme are ignored. The numbering of these
-- files does not correlate to the blocks stored in them.
--
-- Each file stores a fixed number of blocks, specified by
-- 'volMaxBlocksPerFile'. When opening the VolatileDB, it will start appending
-- to the file with the highest number that is not yet full. If all are full or
-- none exist, a new file will be created.
--
-- There is an implicit ordering of block files, which is NOT alpharithmetic.
-- For example, @blocks-20.dat@ < @blocks-100.dat@.
--
-- = Recovery
--
-- The VolatileDB will always try to recover to a consistent state even if this
-- means deleting all of its contents. In order to achieve this, it truncates
-- the files containing blocks if some blocks fail to parse, are invalid, or are
-- duplicated.
module Ouroboros.Consensus.Storage.VolatileDB.Impl (
    -- * Opening the database
    VolatileDbArgs (..)
  , VolatileDbSerialiseConstraints
  , defaultArgs
  , openDB
    -- * Re-exported
  , BlockValidationPolicy (..)
  , BlocksPerFile
  , ParseError (..)
  , TraceEvent (..)
  , extractBlockInfo
  , mkBlocksPerFile
  ) where

import qualified Codec.CBOR.Read as CBOR
import qualified Codec.CBOR.Write as CBOR
import           Control.Monad (unless, when)
import           Control.Monad.State.Strict (get, gets, lift, modify, put,
                     state)
import           Control.Tracer (Tracer, nullTracer, traceWith)
import qualified Data.ByteString.Lazy as Lazy
import           Data.List (foldl')
import qualified Data.Map.Strict as Map
import           Data.Maybe (fromMaybe, mapMaybe)
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Word (Word64)
import           GHC.Stack (HasCallStack)

import           Ouroboros.Network.Block (MaxSlotNo (..))

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Util.Args
import           Ouroboros.Consensus.Util.IOLike
import qualified Ouroboros.Consensus.Util.MonadSTM.RAWLock as RAWLock
import           Ouroboros.Consensus.Util.ResourceRegistry

import           Ouroboros.Consensus.Storage.Common (BlockComponent (..))
import           Ouroboros.Consensus.Storage.FS.API
import           Ouroboros.Consensus.Storage.FS.API.Types
import           Ouroboros.Consensus.Storage.Serialisation

import           Ouroboros.Consensus.Storage.VolatileDB.API
import           Ouroboros.Consensus.Storage.VolatileDB.Impl.FileInfo (FileInfo)
import qualified Ouroboros.Consensus.Storage.VolatileDB.Impl.FileInfo as FileInfo
import qualified Ouroboros.Consensus.Storage.VolatileDB.Impl.Index as Index
import           Ouroboros.Consensus.Storage.VolatileDB.Impl.Parser
import           Ouroboros.Consensus.Storage.VolatileDB.Impl.State
import           Ouroboros.Consensus.Storage.VolatileDB.Impl.Types
import           Ouroboros.Consensus.Storage.VolatileDB.Impl.Util

{------------------------------------------------------------------------------
  Opening the database
------------------------------------------------------------------------------}

data VolatileDbArgs f m blk = VolatileDbArgs {
      VolatileDbArgs f m blk -> HKD f (blk -> Bool)
volCheckIntegrity   :: HKD f (blk -> Bool)
    , VolatileDbArgs f m blk -> HKD f (CodecConfig blk)
volCodecConfig      :: HKD f (CodecConfig blk)
    , VolatileDbArgs f m blk -> SomeHasFS m
volHasFS            :: SomeHasFS m
    , VolatileDbArgs f m blk -> BlocksPerFile
volMaxBlocksPerFile :: BlocksPerFile
    , VolatileDbArgs f m blk -> Tracer m (TraceEvent blk)
volTracer           :: Tracer m (TraceEvent blk)
    , VolatileDbArgs f m blk -> BlockValidationPolicy
volValidationPolicy :: BlockValidationPolicy
    }

-- | Default arguments
defaultArgs :: Applicative m => SomeHasFS m -> VolatileDbArgs Defaults m blk
defaultArgs :: SomeHasFS m -> VolatileDbArgs Defaults m blk
defaultArgs SomeHasFS m
volHasFS = VolatileDbArgs :: forall (f :: * -> *) (m :: * -> *) blk.
HKD f (blk -> Bool)
-> HKD f (CodecConfig blk)
-> SomeHasFS m
-> BlocksPerFile
-> Tracer m (TraceEvent blk)
-> BlockValidationPolicy
-> VolatileDbArgs f m blk
VolatileDbArgs {
      volCheckIntegrity :: HKD Defaults (blk -> Bool)
volCheckIntegrity   = HKD Defaults (blk -> Bool)
forall t. Defaults t
NoDefault
    , volCodecConfig :: HKD Defaults (CodecConfig blk)
volCodecConfig      = HKD Defaults (CodecConfig blk)
forall t. Defaults t
NoDefault
    , SomeHasFS m
volHasFS :: SomeHasFS m
volHasFS :: SomeHasFS m
volHasFS
    , volMaxBlocksPerFile :: BlocksPerFile
volMaxBlocksPerFile = Word32 -> BlocksPerFile
mkBlocksPerFile Word32
1000
    , volTracer :: Tracer m (TraceEvent blk)
volTracer           = Tracer m (TraceEvent blk)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , volValidationPolicy :: BlockValidationPolicy
volValidationPolicy = BlockValidationPolicy
NoValidation
    }

-- | 'EncodeDisk' and 'DecodeDisk' constraints needed for the VolatileDB.
type VolatileDbSerialiseConstraints blk =
  ( EncodeDisk blk blk
  , DecodeDisk blk (Lazy.ByteString -> blk)
  , DecodeDiskDep (NestedCtxt Header) blk
  , HasNestedContent Header blk
  , HasBinaryBlockInfo blk
  )

openDB ::
     forall m blk ans.
     ( HasCallStack
     , IOLike m
     , HasHeader blk
     , GetPrevHash blk
     , VolatileDbSerialiseConstraints blk
     )
  => VolatileDbArgs Identity m blk
  -> (forall st. WithTempRegistry st m (VolatileDB m blk, st) -> ans)
  -> ans
openDB :: VolatileDbArgs Identity m blk
-> (forall st. WithTempRegistry st m (VolatileDB m blk, st) -> ans)
-> ans
openDB VolatileDbArgs { volHasFS :: forall (f :: * -> *) (m :: * -> *) blk.
VolatileDbArgs f m blk -> SomeHasFS m
volHasFS = SomeHasFS HasFS m h
hasFS, Tracer m (TraceEvent blk)
HKD Identity (CodecConfig blk)
HKD Identity (blk -> Bool)
BlockValidationPolicy
BlocksPerFile
volValidationPolicy :: BlockValidationPolicy
volTracer :: Tracer m (TraceEvent blk)
volMaxBlocksPerFile :: BlocksPerFile
volCodecConfig :: HKD Identity (CodecConfig blk)
volCheckIntegrity :: HKD Identity (blk -> Bool)
volValidationPolicy :: forall (f :: * -> *) (m :: * -> *) blk.
VolatileDbArgs f m blk -> BlockValidationPolicy
volTracer :: forall (f :: * -> *) (m :: * -> *) blk.
VolatileDbArgs f m blk -> Tracer m (TraceEvent blk)
volMaxBlocksPerFile :: forall (f :: * -> *) (m :: * -> *) blk.
VolatileDbArgs f m blk -> BlocksPerFile
volCodecConfig :: forall (f :: * -> *) (m :: * -> *) blk.
VolatileDbArgs f m blk -> HKD f (CodecConfig blk)
volCheckIntegrity :: forall (f :: * -> *) (m :: * -> *) blk.
VolatileDbArgs f m blk -> HKD f (blk -> Bool)
.. } forall st. WithTempRegistry st m (VolatileDB m blk, st) -> ans
cont = WithTempRegistry
  (OpenState blk h) m (VolatileDB m blk, OpenState blk h)
-> ans
forall st. WithTempRegistry st m (VolatileDB m blk, st) -> ans
cont (WithTempRegistry
   (OpenState blk h) m (VolatileDB m blk, OpenState blk h)
 -> ans)
-> WithTempRegistry
     (OpenState blk h) m (VolatileDB m blk, OpenState blk h)
-> ans
forall a b. (a -> b) -> a -> b
$ do
    m () -> WithTempRegistry (OpenState blk h) m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WithTempRegistry (OpenState blk h) m ())
-> m () -> WithTempRegistry (OpenState blk h) m ()
forall a b. (a -> b) -> a -> b
$ HasFS m h -> Bool -> FsPath -> m ()
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Bool -> FsPath -> m ()
createDirectoryIfMissing HasFS m h
hasFS Bool
True ([String] -> FsPath
mkFsPath [])
    OpenState blk h
ost <- CodecConfig blk
-> HasFS m h
-> (blk -> Bool)
-> BlockValidationPolicy
-> Tracer m (TraceEvent blk)
-> BlocksPerFile
-> WithTempRegistry (OpenState blk h) m (OpenState blk h)
forall (m :: * -> *) blk h.
(HasCallStack, IOLike m, GetPrevHash blk, HasBinaryBlockInfo blk,
 HasNestedContent Header blk, DecodeDisk blk (ByteString -> blk),
 Eq h) =>
CodecConfig blk
-> HasFS m h
-> (blk -> Bool)
-> BlockValidationPolicy
-> Tracer m (TraceEvent blk)
-> BlocksPerFile
-> WithTempRegistry (OpenState blk h) m (OpenState blk h)
mkOpenState
               HKD Identity (CodecConfig blk)
CodecConfig blk
volCodecConfig
               HasFS m h
hasFS
               HKD Identity (blk -> Bool)
blk -> Bool
volCheckIntegrity
               BlockValidationPolicy
volValidationPolicy
               Tracer m (TraceEvent blk)
volTracer
               BlocksPerFile
volMaxBlocksPerFile
    RAWLock m (InternalState blk h)
stVar <- m (RAWLock m (InternalState blk h))
-> WithTempRegistry
     (OpenState blk h) m (RAWLock m (InternalState blk h))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (RAWLock m (InternalState blk h))
 -> WithTempRegistry
      (OpenState blk h) m (RAWLock m (InternalState blk h)))
-> m (RAWLock m (InternalState blk h))
-> WithTempRegistry
     (OpenState blk h) m (RAWLock m (InternalState blk h))
forall a b. (a -> b) -> a -> b
$ InternalState blk h -> m (RAWLock m (InternalState blk h))
forall (m :: * -> *) st.
(IOLike m, NoThunks st) =>
st -> m (RAWLock m st)
RAWLock.new (OpenState blk h -> InternalState blk h
forall blk h. OpenState blk h -> InternalState blk h
DbOpen OpenState blk h
ost)
    let env :: VolatileDBEnv m blk
env = VolatileDBEnv :: forall (m :: * -> *) blk h.
Eq h =>
HasFS m h
-> RAWLock m (InternalState blk h)
-> BlocksPerFile
-> (blk -> Bool)
-> CodecConfig blk
-> Tracer m (TraceEvent blk)
-> VolatileDBEnv m blk
VolatileDBEnv {
            hasFS :: HasFS m h
hasFS            = HasFS m h
hasFS
          , varInternalState :: RAWLock m (InternalState blk h)
varInternalState = RAWLock m (InternalState blk h)
stVar
          , maxBlocksPerFile :: BlocksPerFile
maxBlocksPerFile = BlocksPerFile
volMaxBlocksPerFile
          , tracer :: Tracer m (TraceEvent blk)
tracer           = Tracer m (TraceEvent blk)
volTracer
          , codecConfig :: CodecConfig blk
codecConfig      = HKD Identity (CodecConfig blk)
CodecConfig blk
volCodecConfig
          , checkIntegrity :: blk -> Bool
checkIntegrity   = HKD Identity (blk -> Bool)
blk -> Bool
volCheckIntegrity
          }
        volatileDB :: VolatileDB m blk
volatileDB = VolatileDB :: forall (m :: * -> *) blk.
(HasCallStack => m ())
-> (forall b.
    HasCallStack =>
    BlockComponent blk b -> HeaderHash blk -> m (Maybe b))
-> (HasCallStack => blk -> m ())
-> (HasCallStack => STM m (ChainHash blk -> Set (HeaderHash blk)))
-> (HasCallStack =>
    STM m (HeaderHash blk -> Maybe (BlockInfo blk)))
-> (HasCallStack => SlotNo -> m ())
-> (HasCallStack => STM m MaxSlotNo)
-> VolatileDB m blk
VolatileDB {
            closeDB :: HasCallStack => m ()
closeDB             = VolatileDBEnv m blk -> m ()
forall (m :: * -> *) blk.
(IOLike m, HasHeader blk) =>
VolatileDBEnv m blk -> m ()
closeDBImpl             VolatileDBEnv m blk
env
          , getBlockComponent :: forall b.
HasCallStack =>
BlockComponent blk b -> HeaderHash blk -> m (Maybe b)
getBlockComponent   = VolatileDBEnv m blk
-> BlockComponent blk b -> HeaderHash blk -> m (Maybe b)
forall (m :: * -> *) blk b.
(IOLike m, HasHeader blk, DecodeDisk blk (ByteString -> blk),
 HasNestedContent Header blk, DecodeDiskDep (NestedCtxt Header) blk,
 HasCallStack) =>
VolatileDBEnv m blk
-> BlockComponent blk b -> HeaderHash blk -> m (Maybe b)
getBlockComponentImpl   VolatileDBEnv m blk
env
          , putBlock :: HasCallStack => blk -> m ()
putBlock            = VolatileDBEnv m blk -> blk -> m ()
forall (m :: * -> *) blk.
(HasHeader blk, GetPrevHash blk, EncodeDisk blk blk,
 HasBinaryBlockInfo blk, HasNestedContent Header blk, IOLike m) =>
VolatileDBEnv m blk -> blk -> m ()
putBlockImpl            VolatileDBEnv m blk
env
          , garbageCollect :: HasCallStack => SlotNo -> m ()
garbageCollect      = VolatileDBEnv m blk -> SlotNo -> m ()
forall (m :: * -> *) blk.
(IOLike m, HasHeader blk) =>
VolatileDBEnv m blk -> SlotNo -> m ()
garbageCollectImpl      VolatileDBEnv m blk
env
          , filterByPredecessor :: HasCallStack => STM m (ChainHash blk -> Set (HeaderHash blk))
filterByPredecessor = VolatileDBEnv m blk
-> STM m (ChainHash blk -> Set (HeaderHash blk))
forall (m :: * -> *) blk.
(IOLike m, HasHeader blk) =>
VolatileDBEnv m blk
-> STM m (ChainHash blk -> Set (HeaderHash blk))
filterByPredecessorImpl VolatileDBEnv m blk
env
          , getBlockInfo :: HasCallStack => STM m (HeaderHash blk -> Maybe (BlockInfo blk))
getBlockInfo        = VolatileDBEnv m blk
-> STM m (HeaderHash blk -> Maybe (BlockInfo blk))
forall (m :: * -> *) blk.
(IOLike m, HasHeader blk) =>
VolatileDBEnv m blk
-> STM m (HeaderHash blk -> Maybe (BlockInfo blk))
getBlockInfoImpl        VolatileDBEnv m blk
env
          , getMaxSlotNo :: HasCallStack => STM m MaxSlotNo
getMaxSlotNo        = VolatileDBEnv m blk -> STM m MaxSlotNo
forall (m :: * -> *) blk.
(IOLike m, HasHeader blk) =>
VolatileDBEnv m blk -> STM m MaxSlotNo
getMaxSlotNoImpl        VolatileDBEnv m blk
env
          }
    (VolatileDB m blk, OpenState blk h)
-> WithTempRegistry
     (OpenState blk h) m (VolatileDB m blk, OpenState blk h)
forall (m :: * -> *) a. Monad m => a -> m a
return (VolatileDB m blk
volatileDB, OpenState blk h
ost)

{------------------------------------------------------------------------------
  VolatileDB API
------------------------------------------------------------------------------}

closeDBImpl ::
     forall m blk. (IOLike m, HasHeader blk)
  => VolatileDBEnv m blk
  -> m ()
closeDBImpl :: VolatileDBEnv m blk -> m ()
closeDBImpl VolatileDBEnv { RAWLock m (InternalState blk h)
varInternalState :: RAWLock m (InternalState blk h)
varInternalState :: ()
varInternalState, Tracer m (TraceEvent blk)
tracer :: Tracer m (TraceEvent blk)
tracer :: forall (m :: * -> *) blk.
VolatileDBEnv m blk -> Tracer m (TraceEvent blk)
tracer, HasFS m h
hasFS :: HasFS m h
hasFS :: ()
hasFS } = do
    InternalState blk h
mbInternalState <-
      RAWLock m (InternalState blk h)
-> (InternalState blk h
    -> m (InternalState blk h, InternalState blk h))
-> m (InternalState blk h)
forall (m :: * -> *) st a.
IOLike m =>
RAWLock m st -> (st -> m (st, a)) -> m a
RAWLock.withWriteAccess RAWLock m (InternalState blk h)
varInternalState ((InternalState blk h
  -> m (InternalState blk h, InternalState blk h))
 -> m (InternalState blk h))
-> (InternalState blk h
    -> m (InternalState blk h, InternalState blk h))
-> m (InternalState blk h)
forall a b. (a -> b) -> a -> b
$ \InternalState blk h
st -> (InternalState blk h, InternalState blk h)
-> m (InternalState blk h, InternalState blk h)
forall (m :: * -> *) a. Monad m => a -> m a
return (InternalState blk h
forall blk h. InternalState blk h
DbClosed, InternalState blk h
st)
    case InternalState blk h
mbInternalState of
      InternalState blk h
DbClosed -> 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
DBAlreadyClosed
      DbOpen OpenState blk h
ost ->
        Proxy blk -> m () -> m ()
forall (m :: * -> *) a blk.
(MonadCatch m, StandardHash blk, Typeable blk) =>
Proxy blk -> m a -> m a
wrapFsError (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ HasFS m h -> OpenState blk h -> m ()
forall (m :: * -> *) h blk. HasFS m h -> OpenState blk h -> m ()
closeOpenHandles HasFS m h
hasFS OpenState blk h
ost

getBlockComponentImpl ::
     forall m blk b.
     ( IOLike m
     , HasHeader blk
     , DecodeDisk blk (Lazy.ByteString -> blk)
     , HasNestedContent Header blk
     , DecodeDiskDep (NestedCtxt Header) blk
     , HasCallStack
     )
  => VolatileDBEnv m blk
  -> BlockComponent blk b
  -> HeaderHash blk
  -> m (Maybe b)
getBlockComponentImpl :: VolatileDBEnv m blk
-> BlockComponent blk b -> HeaderHash blk -> m (Maybe b)
getBlockComponentImpl env :: VolatileDBEnv m blk
env@VolatileDBEnv { CodecConfig blk
codecConfig :: CodecConfig blk
codecConfig :: forall (m :: * -> *) blk. VolatileDBEnv m blk -> CodecConfig blk
codecConfig, blk -> Bool
checkIntegrity :: blk -> Bool
checkIntegrity :: forall (m :: * -> *) blk. VolatileDBEnv m blk -> blk -> Bool
checkIntegrity } BlockComponent blk b
blockComponent HeaderHash blk
hash =
    VolatileDBEnv m blk
-> (forall h. HasFS m h -> OpenState blk h -> m (Maybe b))
-> m (Maybe b)
forall blk (m :: * -> *) r.
(IOLike m, StandardHash blk, Typeable blk) =>
VolatileDBEnv m blk
-> (forall h. HasFS m h -> OpenState blk h -> m r) -> m r
withOpenState VolatileDBEnv m blk
env ((forall h. HasFS m h -> OpenState blk h -> m (Maybe b))
 -> m (Maybe b))
-> (forall h. HasFS m h -> OpenState blk h -> m (Maybe b))
-> m (Maybe b)
forall a b. (a -> b) -> a -> b
$ \HasFS m h
hasFS OpenState { ReverseIndex blk
currentRevMap :: forall blk h. OpenState blk h -> ReverseIndex blk
currentRevMap :: ReverseIndex blk
currentRevMap } ->
      case HeaderHash blk -> ReverseIndex blk -> Maybe (InternalBlockInfo blk)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup HeaderHash blk
hash ReverseIndex blk
currentRevMap of
        Maybe (InternalBlockInfo blk)
Nothing                -> Maybe b -> m (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing
        Just InternalBlockInfo blk
internalBlockInfo -> b -> Maybe b
forall a. a -> Maybe a
Just (b -> Maybe b) -> m b -> m (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          HasFS m h -> InternalBlockInfo blk -> BlockComponent blk b -> m b
forall b' h.
HasFS m h -> InternalBlockInfo blk -> BlockComponent blk b' -> m b'
getBlockComponent HasFS m h
hasFS InternalBlockInfo blk
internalBlockInfo BlockComponent blk b
blockComponent
  where
    getBlockComponent ::
         forall b' h. HasFS m h
      -> InternalBlockInfo blk
      -> BlockComponent blk b'
      -> m b'
    getBlockComponent :: HasFS m h -> InternalBlockInfo blk -> BlockComponent blk b' -> m b'
getBlockComponent HasFS m h
hasFS InternalBlockInfo blk
ibi = \case
        BlockComponent blk b'
GetHash          -> b' -> m b'
forall (m :: * -> *) a. Monad m => a -> m a
return b'
HeaderHash blk
hash
        BlockComponent blk b'
GetSlot          -> SlotNo -> m SlotNo
forall (m :: * -> *) a. Monad m => a -> m a
return SlotNo
biSlotNo
        BlockComponent blk b'
GetIsEBB         -> IsEBB -> m IsEBB
forall (m :: * -> *) a. Monad m => a -> m a
return IsEBB
biIsEBB
        BlockComponent blk b'
GetBlockSize     -> b' -> m b'
forall (m :: * -> *) a. Monad m => a -> m a
return (b' -> m b') -> b' -> m b'
forall a b. (a -> b) -> a -> b
$ Word32 -> b'
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> b') -> Word32 -> b'
forall a b. (a -> b) -> a -> b
$ BlockSize -> Word32
unBlockSize BlockSize
ibiBlockSize
        BlockComponent blk b'
GetHeaderSize    -> Word16 -> m Word16
forall (m :: * -> *) a. Monad m => a -> m a
return Word16
biHeaderSize
        GetPure b'
a        -> b' -> m b'
forall (m :: * -> *) a. Monad m => a -> m a
return b'
a
        GetApply BlockComponent blk (a -> b')
f BlockComponent blk a
bc    ->
          HasFS m h
-> InternalBlockInfo blk
-> BlockComponent blk (a -> b')
-> m (a -> b')
forall b' h.
HasFS m h -> InternalBlockInfo blk -> BlockComponent blk b' -> m b'
getBlockComponent HasFS m h
hasFS InternalBlockInfo blk
ibi BlockComponent blk (a -> b')
f m (a -> b') -> m a -> m b'
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HasFS m h -> InternalBlockInfo blk -> BlockComponent blk a -> m a
forall b' h.
HasFS m h -> InternalBlockInfo blk -> BlockComponent blk b' -> m b'
getBlockComponent HasFS m h
hasFS InternalBlockInfo blk
ibi BlockComponent blk a
bc
        BlockComponent blk b'
GetBlock         ->
          HasFS m h
-> InternalBlockInfo blk
-> BlockComponent blk ByteString
-> m ByteString
forall b' h.
HasFS m h -> InternalBlockInfo blk -> BlockComponent blk b' -> m b'
getBlockComponent HasFS m h
hasFS InternalBlockInfo blk
ibi BlockComponent blk ByteString
forall blk. BlockComponent blk ByteString
GetRawBlock m ByteString -> (ByteString -> m blk) -> m blk
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> m blk
parseBlock
        BlockComponent blk b'
GetRawBlock      -> HasFS m h
-> FsPath -> OpenMode -> (Handle h -> m ByteString) -> m ByteString
forall (m :: * -> *) h a.
(HasCallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS m h
hasFS FsPath
ibiFile OpenMode
ReadMode ((Handle h -> m ByteString) -> m ByteString)
-> (Handle h -> m ByteString) -> m ByteString
forall a b. (a -> b) -> a -> b
$ \Handle h
hndl -> do
          let size :: Word64
size   = Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word64) -> Word32 -> Word64
forall a b. (a -> b) -> a -> b
$ BlockSize -> Word32
unBlockSize BlockSize
ibiBlockSize
              offset :: Word64
offset = BlockOffset -> Word64
unBlockOffset BlockOffset
ibiBlockOffset
          HasFS m h -> Handle h -> Word64 -> AbsOffset -> m ByteString
forall (m :: * -> *) h.
(HasCallStack, MonadThrow m) =>
HasFS m h -> Handle h -> Word64 -> AbsOffset -> m ByteString
hGetExactlyAt HasFS m h
hasFS Handle h
hndl Word64
size (Word64 -> AbsOffset
AbsOffset Word64
offset)
        BlockComponent blk b'
GetHeader        ->
          HasFS m h
-> InternalBlockInfo blk
-> BlockComponent blk ByteString
-> m ByteString
forall b' h.
HasFS m h -> InternalBlockInfo blk -> BlockComponent blk b' -> m b'
getBlockComponent HasFS m h
hasFS InternalBlockInfo blk
ibi BlockComponent blk ByteString
forall blk. BlockComponent blk ByteString
GetRawHeader m ByteString -> (ByteString -> m (Header blk)) -> m (Header blk)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> m (Header blk)
parseHeader
        BlockComponent blk b'
GetRawHeader     -> HasFS m h
-> FsPath -> OpenMode -> (Handle h -> m ByteString) -> m ByteString
forall (m :: * -> *) h a.
(HasCallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS m h
hasFS FsPath
ibiFile OpenMode
ReadMode ((Handle h -> m ByteString) -> m ByteString)
-> (Handle h -> m ByteString) -> m ByteString
forall a b. (a -> b) -> a -> b
$ \Handle h
hndl -> do
          let size :: Word64
size   = Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
biHeaderSize
              offset :: Word64
offset = BlockOffset -> Word64
unBlockOffset BlockOffset
ibiBlockOffset Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
biHeaderOffset
          HasFS m h -> Handle h -> Word64 -> AbsOffset -> m ByteString
forall (m :: * -> *) h.
(HasCallStack, MonadThrow m) =>
HasFS m h -> Handle h -> Word64 -> AbsOffset -> m ByteString
hGetExactlyAt HasFS m h
hasFS Handle h
hndl Word64
size (Word64 -> AbsOffset
AbsOffset Word64
offset)
        BlockComponent blk b'
GetNestedCtxt    -> SomeSecond (NestedCtxt Header) blk
-> m (SomeSecond (NestedCtxt Header) blk)
forall (m :: * -> *) a. Monad m => a -> m a
return SomeSecond (NestedCtxt Header) blk
ibiNestedCtxt
        BlockComponent blk b'
GetVerifiedBlock ->
          HasFS m h
-> InternalBlockInfo blk -> BlockComponent blk blk -> m blk
forall b' h.
HasFS m h -> InternalBlockInfo blk -> BlockComponent blk b' -> m b'
getBlockComponent HasFS m h
hasFS InternalBlockInfo blk
ibi BlockComponent blk blk
forall blk. BlockComponent blk blk
GetBlock m blk -> (blk -> m blk) -> m blk
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \blk
blk -> do
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (blk -> Bool
checkIntegrity blk
blk) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
              VolatileDBError blk -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (VolatileDBError blk -> m ()) -> VolatileDBError blk -> m ()
forall a b. (a -> b) -> a -> b
$ UnexpectedFailure blk -> VolatileDBError blk
forall blk. UnexpectedFailure blk -> VolatileDBError blk
UnexpectedFailure (UnexpectedFailure blk -> VolatileDBError blk)
-> UnexpectedFailure blk -> VolatileDBError blk
forall a b. (a -> b) -> a -> b
$ HeaderHash blk -> UnexpectedFailure blk
forall blk. HeaderHash blk -> UnexpectedFailure blk
CorruptBlockError @blk HeaderHash blk
hash
            blk -> m blk
forall (m :: * -> *) a. Monad m => a -> m a
return blk
blk
      where
        InternalBlockInfo { ibiBlockInfo :: forall blk. InternalBlockInfo blk -> BlockInfo blk
ibiBlockInfo = BlockInfo {Word16
SlotNo
BlockNo
HeaderHash blk
ChainHash blk
IsEBB
biHeaderSize :: forall blk. BlockInfo blk -> Word16
biHeaderOffset :: forall blk. BlockInfo blk -> Word16
biIsEBB :: forall blk. BlockInfo blk -> IsEBB
biPrevHash :: forall blk. BlockInfo blk -> ChainHash blk
biBlockNo :: forall blk. BlockInfo blk -> BlockNo
biSlotNo :: forall blk. BlockInfo blk -> SlotNo
biHash :: forall blk. BlockInfo blk -> HeaderHash blk
biPrevHash :: ChainHash blk
biBlockNo :: BlockNo
biHash :: HeaderHash blk
biHeaderOffset :: Word16
biHeaderSize :: Word16
biIsEBB :: IsEBB
biSlotNo :: SlotNo
..}, SomeSecond (NestedCtxt Header) blk
FsPath
BlockOffset
BlockSize
ibiNestedCtxt :: forall blk.
InternalBlockInfo blk -> SomeSecond (NestedCtxt Header) blk
ibiBlockSize :: forall blk. InternalBlockInfo blk -> BlockSize
ibiBlockOffset :: forall blk. InternalBlockInfo blk -> BlockOffset
ibiFile :: forall blk. InternalBlockInfo blk -> FsPath
ibiNestedCtxt :: SomeSecond (NestedCtxt Header) blk
ibiBlockOffset :: BlockOffset
ibiFile :: FsPath
ibiBlockSize :: BlockSize
.. } = InternalBlockInfo blk
ibi

        parseBlock :: Lazy.ByteString -> m blk
        parseBlock :: ByteString -> m blk
parseBlock ByteString
bytes = ByteString
-> Either DeserialiseFailure (ByteString, ByteString -> blk)
-> m blk
forall b''.
ByteString
-> Either DeserialiseFailure (ByteString, ByteString -> b'')
-> m b''
throwParseErrors ByteString
bytes (Either DeserialiseFailure (ByteString, ByteString -> blk)
 -> m blk)
-> Either DeserialiseFailure (ByteString, ByteString -> blk)
-> m blk
forall a b. (a -> b) -> a -> b
$
            (forall s. Decoder s (ByteString -> blk))
-> ByteString
-> Either DeserialiseFailure (ByteString, ByteString -> blk)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes (CodecConfig blk -> forall s. Decoder s (ByteString -> blk)
forall blk a.
DecodeDisk blk a =>
CodecConfig blk -> forall s. Decoder s a
decodeDisk CodecConfig blk
codecConfig) ByteString
bytes

        parseHeader :: Lazy.ByteString -> m (Header blk)
        parseHeader :: ByteString -> m (Header blk)
parseHeader ByteString
bytes = ByteString
-> Either DeserialiseFailure (ByteString, ByteString -> Header blk)
-> m (Header blk)
forall b''.
ByteString
-> Either DeserialiseFailure (ByteString, ByteString -> b'')
-> m b''
throwParseErrors ByteString
bytes (Either DeserialiseFailure (ByteString, ByteString -> Header blk)
 -> m (Header blk))
-> Either DeserialiseFailure (ByteString, ByteString -> Header blk)
-> m (Header blk)
forall a b. (a -> b) -> a -> b
$
            case SomeSecond (NestedCtxt Header) blk
ibiNestedCtxt of
              SomeSecond NestedCtxt Header blk b
ctxt ->
                (forall s. Decoder s (ByteString -> Header blk))
-> ByteString
-> Either DeserialiseFailure (ByteString, ByteString -> Header blk)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes
                  ((\ByteString -> b
f -> DepPair (NestedCtxt Header blk) -> Header blk
forall (f :: * -> *) blk.
HasNestedContent f blk =>
DepPair (NestedCtxt f blk) -> f blk
nest (DepPair (NestedCtxt Header blk) -> Header blk)
-> (ByteString -> DepPair (NestedCtxt Header blk))
-> ByteString
-> Header blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NestedCtxt Header blk b -> b -> DepPair (NestedCtxt Header blk)
forall (f :: * -> *) a. f a -> a -> DepPair f
DepPair NestedCtxt Header blk b
ctxt (b -> DepPair (NestedCtxt Header blk))
-> (ByteString -> b)
-> ByteString
-> DepPair (NestedCtxt Header blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> b
f) ((ByteString -> b) -> ByteString -> Header blk)
-> Decoder s (ByteString -> b)
-> Decoder s (ByteString -> Header blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                      CodecConfig blk
-> NestedCtxt Header blk b -> forall s. Decoder s (ByteString -> b)
forall (f :: * -> * -> *) blk a.
DecodeDiskDep f blk =>
CodecConfig blk -> f blk a -> forall s. Decoder s (ByteString -> a)
decodeDiskDep CodecConfig blk
codecConfig NestedCtxt Header blk b
ctxt)
                  ByteString
bytes

        pt :: RealPoint blk
        pt :: RealPoint blk
pt = SlotNo -> HeaderHash blk -> RealPoint blk
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint SlotNo
biSlotNo HeaderHash blk
hash

        throwParseErrors ::
             forall b''.
             Lazy.ByteString
          -> Either CBOR.DeserialiseFailure (Lazy.ByteString, Lazy.ByteString -> b'')
          -> m b''
        throwParseErrors :: ByteString
-> Either DeserialiseFailure (ByteString, ByteString -> b'')
-> m b''
throwParseErrors ByteString
fullBytes = \case
            Right (ByteString
trailing, ByteString -> b''
f)
              | ByteString -> Bool
Lazy.null ByteString
trailing
              -> b'' -> m b''
forall (m :: * -> *) a. Monad m => a -> m a
return (b'' -> m b'') -> b'' -> m b''
forall a b. (a -> b) -> a -> b
$ ByteString -> b''
f ByteString
fullBytes
              | Bool
otherwise
              -> VolatileDBError blk -> m b''
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (VolatileDBError blk -> m b'') -> VolatileDBError blk -> m b''
forall a b. (a -> b) -> a -> b
$ UnexpectedFailure blk -> VolatileDBError blk
forall blk. UnexpectedFailure blk -> VolatileDBError blk
UnexpectedFailure (UnexpectedFailure blk -> VolatileDBError blk)
-> UnexpectedFailure blk -> VolatileDBError blk
forall a b. (a -> b) -> a -> b
$ FsPath -> RealPoint blk -> ByteString -> UnexpectedFailure blk
forall blk.
FsPath -> RealPoint blk -> ByteString -> UnexpectedFailure blk
TrailingDataError FsPath
ibiFile RealPoint blk
pt ByteString
trailing
            Left DeserialiseFailure
err
              -> VolatileDBError blk -> m b''
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (VolatileDBError blk -> m b'') -> VolatileDBError blk -> m b''
forall a b. (a -> b) -> a -> b
$ UnexpectedFailure blk -> VolatileDBError blk
forall blk. UnexpectedFailure blk -> VolatileDBError blk
UnexpectedFailure (UnexpectedFailure blk -> VolatileDBError blk)
-> UnexpectedFailure blk -> VolatileDBError blk
forall a b. (a -> b) -> a -> b
$ FsPath
-> RealPoint blk -> DeserialiseFailure -> UnexpectedFailure blk
forall blk.
FsPath
-> RealPoint blk -> DeserialiseFailure -> UnexpectedFailure blk
ParseError FsPath
ibiFile RealPoint blk
pt DeserialiseFailure
err

-- | This function follows the approach:
-- (1) hPut bytes to the file
-- (2) if full hClose the write file
-- (3)         hOpen a new write file
-- (4) update the Internal State.
--
-- If there is an error after (1) or after (2) we should make sure that when
-- we reopen a db from scratch, it can successfully recover, even if it does
-- not find an empty file to write and all other files are full.
--
-- We should also make sure that the db can recover if we get an
-- exception/error at any moment and that we are left with an empty Internal
-- State.
--
-- We should be careful about not leaking open fds when we open a new file,
-- since this can affect garbage collection of files.
putBlockImpl ::
     forall m blk.
     ( HasHeader blk
     , GetPrevHash blk
     , EncodeDisk blk blk
     , HasBinaryBlockInfo blk
     , HasNestedContent Header blk
     , IOLike m
     )
  => VolatileDBEnv m blk
  -> blk
  -> m ()
putBlockImpl :: VolatileDBEnv m blk -> blk -> m ()
putBlockImpl env :: VolatileDBEnv m blk
env@VolatileDBEnv{ BlocksPerFile
maxBlocksPerFile :: BlocksPerFile
maxBlocksPerFile :: forall (m :: * -> *) blk. VolatileDBEnv m blk -> BlocksPerFile
maxBlocksPerFile, Tracer m (TraceEvent blk)
tracer :: Tracer m (TraceEvent blk)
tracer :: forall (m :: * -> *) blk.
VolatileDBEnv m blk -> Tracer m (TraceEvent blk)
tracer, CodecConfig blk
codecConfig :: CodecConfig blk
codecConfig :: forall (m :: * -> *) blk. VolatileDBEnv m blk -> CodecConfig blk
codecConfig }
             blk
blk =
    VolatileDBEnv m blk
-> (forall h. Eq h => HasFS m h -> ModifyOpenState m blk h ())
-> m ()
forall blk (m :: * -> *) a.
(IOLike m, Typeable blk, StandardHash blk) =>
VolatileDBEnv m blk
-> (forall h. Eq h => HasFS m h -> ModifyOpenState m blk h a)
-> m a
appendOpenState VolatileDBEnv m blk
env ((forall h. Eq h => HasFS m h -> ModifyOpenState m blk h ())
 -> m ())
-> (forall h. Eq h => HasFS m h -> ModifyOpenState m blk h ())
-> m ()
forall a b. (a -> b) -> a -> b
$ \HasFS m h
hasFS -> do
      OpenState { ReverseIndex blk
currentRevMap :: ReverseIndex blk
currentRevMap :: forall blk h. OpenState blk h -> ReverseIndex blk
currentRevMap, Handle h
currentWriteHandle :: forall blk h. OpenState blk h -> Handle h
currentWriteHandle :: Handle h
currentWriteHandle } <- StateT
  (OpenState blk h)
  (WithTempRegistry (OpenState blk h) m)
  (OpenState blk h)
forall s (m :: * -> *). MonadState s m => m s
get
      if HeaderHash blk -> ReverseIndex blk -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member HeaderHash blk
biHash ReverseIndex blk
currentRevMap then
        WithTempRegistry (OpenState blk h) m ()
-> ModifyOpenState m blk h ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WithTempRegistry (OpenState blk h) m ()
 -> ModifyOpenState m blk h ())
-> WithTempRegistry (OpenState blk h) m ()
-> ModifyOpenState m blk h ()
forall a b. (a -> b) -> a -> b
$ m () -> WithTempRegistry (OpenState blk h) m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WithTempRegistry (OpenState blk h) m ())
-> m () -> WithTempRegistry (OpenState 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
$ HeaderHash blk -> TraceEvent blk
forall blk. HeaderHash blk -> TraceEvent blk
BlockAlreadyHere HeaderHash blk
biHash
      else do
        let bytes :: ByteString
bytes = Encoding -> ByteString
CBOR.toLazyByteString (Encoding -> ByteString) -> Encoding -> ByteString
forall a b. (a -> b) -> a -> b
$ CodecConfig blk -> blk -> Encoding
forall blk a. EncodeDisk blk a => CodecConfig blk -> a -> Encoding
encodeDisk CodecConfig blk
codecConfig blk
blk
        Word64
bytesWritten <- WithTempRegistry (OpenState blk h) m Word64
-> StateT
     (OpenState blk h) (WithTempRegistry (OpenState blk h) m) Word64
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WithTempRegistry (OpenState blk h) m Word64
 -> StateT
      (OpenState blk h) (WithTempRegistry (OpenState blk h) m) Word64)
-> WithTempRegistry (OpenState blk h) m Word64
-> StateT
     (OpenState blk h) (WithTempRegistry (OpenState blk h) m) Word64
forall a b. (a -> b) -> a -> b
$ m Word64 -> WithTempRegistry (OpenState blk h) m Word64
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Word64 -> WithTempRegistry (OpenState blk h) m Word64)
-> m Word64 -> WithTempRegistry (OpenState blk h) m Word64
forall a b. (a -> b) -> a -> b
$ HasFS m h -> Handle h -> ByteString -> m Word64
forall (m :: * -> *) h.
(HasCallStack, Monad m) =>
HasFS m h -> Handle h -> ByteString -> m Word64
hPutAll HasFS m h
hasFS Handle h
currentWriteHandle ByteString
bytes
        Bool
fileIsFull <- (OpenState blk h -> (Bool, OpenState blk h))
-> StateT
     (OpenState blk h) (WithTempRegistry (OpenState blk h) m) Bool
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((OpenState blk h -> (Bool, OpenState blk h))
 -> StateT
      (OpenState blk h) (WithTempRegistry (OpenState blk h) m) Bool)
-> (OpenState blk h -> (Bool, OpenState blk h))
-> StateT
     (OpenState blk h) (WithTempRegistry (OpenState blk h) m) Bool
forall a b. (a -> b) -> a -> b
$ Word64 -> OpenState blk h -> (Bool, OpenState blk h)
forall h. Word64 -> OpenState blk h -> (Bool, OpenState blk h)
updateStateAfterWrite Word64
bytesWritten
        Bool -> ModifyOpenState m blk h () -> ModifyOpenState m blk h ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fileIsFull (ModifyOpenState m blk h () -> ModifyOpenState m blk h ())
-> ModifyOpenState m blk h () -> ModifyOpenState m blk h ()
forall a b. (a -> b) -> a -> b
$ HasFS m h -> ModifyOpenState m blk h ()
forall h (m :: * -> *) blk.
(IOLike m, Eq h) =>
HasFS m h -> ModifyOpenState m blk h ()
nextFile HasFS m h
hasFS
  where
    blockInfo :: BlockInfo blk
blockInfo@BlockInfo { HeaderHash blk
biHash :: HeaderHash blk
biHash :: forall blk. BlockInfo blk -> HeaderHash blk
biHash, SlotNo
biSlotNo :: SlotNo
biSlotNo :: forall blk. BlockInfo blk -> SlotNo
biSlotNo, ChainHash blk
biPrevHash :: ChainHash blk
biPrevHash :: forall blk. BlockInfo blk -> ChainHash blk
biPrevHash } = blk -> BlockInfo blk
forall blk.
(GetPrevHash blk, HasBinaryBlockInfo blk) =>
blk -> BlockInfo blk
extractBlockInfo blk
blk

    updateStateAfterWrite
      :: forall h.
         Word64
      -> OpenState blk h
      -> (Bool, OpenState blk h)  -- ^ True: current file is full
    updateStateAfterWrite :: Word64 -> OpenState blk h -> (Bool, OpenState blk h)
updateStateAfterWrite Word64
bytesWritten st :: OpenState blk h
st@OpenState{FileId
Word64
ReverseIndex blk
SuccessorsIndex blk
MaxSlotNo
Handle h
FsPath
Index blk
currentMaxSlotNo :: forall blk h. OpenState blk h -> MaxSlotNo
currentSuccMap :: forall blk h. OpenState blk h -> SuccessorsIndex blk
currentMap :: forall blk h. OpenState blk h -> Index blk
currentWriteOffset :: forall blk h. OpenState blk h -> Word64
currentWriteId :: forall blk h. OpenState blk h -> FileId
currentWritePath :: forall blk h. OpenState blk h -> FsPath
currentMaxSlotNo :: MaxSlotNo
currentSuccMap :: SuccessorsIndex blk
currentRevMap :: ReverseIndex blk
currentMap :: Index blk
currentWriteOffset :: Word64
currentWriteId :: FileId
currentWritePath :: FsPath
currentWriteHandle :: Handle h
currentWriteHandle :: forall blk h. OpenState blk h -> Handle h
currentRevMap :: forall blk h. OpenState blk h -> ReverseIndex blk
..} =
        (BlocksPerFile -> FileInfo blk -> Bool
forall blk. BlocksPerFile -> FileInfo blk -> Bool
FileInfo.isFull BlocksPerFile
maxBlocksPerFile FileInfo blk
fileInfo', OpenState blk h
st')
      where
        fileInfo :: FileInfo blk
fileInfo = FileInfo blk -> Maybe (FileInfo blk) -> FileInfo blk
forall a. a -> Maybe a -> a
fromMaybe
            (String -> FileInfo blk
forall a. HasCallStack => String -> a
error (String -> FileInfo blk) -> String -> FileInfo blk
forall a b. (a -> b) -> a -> b
$ String
"VolatileDB invariant violation:"
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Current write file not found in Index.")
            (FileId -> Index blk -> Maybe (FileInfo blk)
forall blk. FileId -> Index blk -> Maybe (FileInfo blk)
Index.lookup FileId
currentWriteId Index blk
currentMap)
        fileInfo' :: FileInfo blk
fileInfo' = SlotNo -> HeaderHash blk -> FileInfo blk -> FileInfo blk
forall blk.
StandardHash blk =>
SlotNo -> HeaderHash blk -> FileInfo blk -> FileInfo blk
FileInfo.addBlock SlotNo
biSlotNo HeaderHash blk
biHash FileInfo blk
fileInfo
        currentMap' :: Index blk
currentMap' = FileId -> FileInfo blk -> Index blk -> Index blk
forall blk. FileId -> FileInfo blk -> Index blk -> Index blk
Index.insert FileId
currentWriteId FileInfo blk
fileInfo' Index blk
currentMap
        internalBlockInfo' :: InternalBlockInfo blk
internalBlockInfo' = InternalBlockInfo :: forall blk.
FsPath
-> BlockOffset
-> BlockSize
-> BlockInfo blk
-> SomeSecond (NestedCtxt Header) blk
-> InternalBlockInfo blk
InternalBlockInfo {
            ibiFile :: FsPath
ibiFile         = FsPath
currentWritePath
          , ibiBlockOffset :: BlockOffset
ibiBlockOffset  = Word64 -> BlockOffset
BlockOffset Word64
currentWriteOffset
          , ibiBlockSize :: BlockSize
ibiBlockSize    = Word32 -> BlockSize
BlockSize (Word32 -> BlockSize) -> Word32 -> BlockSize
forall a b. (a -> b) -> a -> b
$ Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
bytesWritten
          , ibiBlockInfo :: BlockInfo blk
ibiBlockInfo    = BlockInfo blk
blockInfo
          , ibiNestedCtxt :: SomeSecond (NestedCtxt Header) blk
ibiNestedCtxt   = case Header blk -> DepPair (NestedCtxt Header blk)
forall (f :: * -> *) blk.
HasNestedContent f blk =>
f blk -> DepPair (NestedCtxt f blk)
unnest (blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
blk) of
                                DepPair NestedCtxt Header blk a
nestedCtxt a
_ -> NestedCtxt Header blk a -> SomeSecond (NestedCtxt Header) blk
forall (f :: * -> * -> *) a b. f a b -> SomeSecond f a
SomeSecond NestedCtxt Header blk a
nestedCtxt
          }
        currentRevMap' :: ReverseIndex blk
currentRevMap' = HeaderHash blk
-> InternalBlockInfo blk -> ReverseIndex blk -> ReverseIndex blk
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert HeaderHash blk
biHash InternalBlockInfo blk
internalBlockInfo' ReverseIndex blk
currentRevMap
        st' :: OpenState blk h
st' = OpenState blk h
st {
            currentWriteOffset :: Word64
currentWriteOffset = Word64
currentWriteOffset Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
bytesWritten
          , currentMap :: Index blk
currentMap         = Index blk
currentMap'
          , currentRevMap :: ReverseIndex blk
currentRevMap      = ReverseIndex blk
currentRevMap'
          , currentSuccMap :: SuccessorsIndex blk
currentSuccMap     = ChainHash blk
-> HeaderHash blk -> SuccessorsIndex blk -> SuccessorsIndex blk
forall k v.
(Ord k, Ord v) =>
k -> v -> Map k (Set v) -> Map k (Set v)
insertMapSet ChainHash blk
biPrevHash HeaderHash blk
biHash SuccessorsIndex blk
currentSuccMap
          , currentMaxSlotNo :: MaxSlotNo
currentMaxSlotNo   = MaxSlotNo
currentMaxSlotNo MaxSlotNo -> MaxSlotNo -> MaxSlotNo
forall a. Ord a => a -> a -> a
`max` SlotNo -> MaxSlotNo
MaxSlotNo SlotNo
biSlotNo
          }

-- | Garbage collect all files of which the highest slot is less than the
-- given slot.
--
-- We first check whether we actually can garbage collect any file. If we can,
-- we obtain the more expensive write lock and remove the files that can be
-- garbage collected. We update the 'InternalState' for each garbage collected
-- file.
--
-- If an exception is thrown while garbage collecting, we close the database.
-- This means we don't have to worry the file system getting out of sync with
-- the in-memory indices, as the indices are rebuilt when reopening.
--
-- NOTE: the current file is never garbage collected.
garbageCollectImpl ::
     forall m blk. (IOLike m, HasHeader blk)
  => VolatileDBEnv m blk
  -> SlotNo
  -> m ()
garbageCollectImpl :: VolatileDBEnv m blk -> SlotNo -> m ()
garbageCollectImpl VolatileDBEnv m blk
env SlotNo
slot = do
    -- Check if we can actually GC something using a cheaper read (allowing
    -- for more concurrency) before obtaining the more expensive exclusive
    -- write lock.
    Bool
usefulGC <- STM m Bool -> m Bool
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m Bool -> m Bool) -> STM m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ (forall h. OpenState blk h -> Bool)
-> VolatileDBEnv m blk -> STM m Bool
forall (m :: * -> *) blk a.
(IOLike m, HasHeader blk) =>
(forall h. OpenState blk h -> a) -> VolatileDBEnv m blk -> STM m a
getterSTM forall h. OpenState blk h -> Bool
gcPossible VolatileDBEnv m blk
env

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
usefulGC (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      VolatileDBEnv m blk
-> (forall h. Eq h => HasFS m h -> ModifyOpenState m blk h ())
-> m ()
forall blk (m :: * -> *) a.
(IOLike m, Typeable blk, StandardHash blk) =>
VolatileDBEnv m blk
-> (forall h. Eq h => HasFS m h -> ModifyOpenState m blk h a)
-> m a
writeOpenState VolatileDBEnv m blk
env ((forall h. Eq h => HasFS m h -> ModifyOpenState m blk h ())
 -> m ())
-> (forall h. Eq h => HasFS m h -> ModifyOpenState m blk h ())
-> m ()
forall a b. (a -> b) -> a -> b
$ \HasFS m h
hasFS -> do
        -- This event will be picked up by ghc-events-analyze
        WithTempRegistry (OpenState blk h) m ()
-> ModifyOpenState m blk h ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WithTempRegistry (OpenState blk h) m ()
 -> ModifyOpenState m blk h ())
-> WithTempRegistry (OpenState blk h) m ()
-> ModifyOpenState m blk h ()
forall a b. (a -> b) -> a -> b
$ m () -> WithTempRegistry (OpenState blk h) m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WithTempRegistry (OpenState blk h) m ())
-> m () -> WithTempRegistry (OpenState blk h) m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall (m :: * -> *). MonadEventlog m => String -> m ()
traceEventIO String
"START garbage collection"
        -- Note that this is /monotonic/: if 'usefulGC' is @True@, then
        -- 'filesToGC' has to be non-empty.
        --
        -- Only a single thread performs garbage collection, so no files could
        -- have been GC'ed in the meantime. The only thing that could have
        -- happened is that blocks have been appended. If they have been
        -- appended to the current file, nothing changes, as we never GC the
        -- current file anyway. If a new file was opened, either we can now GC
        -- the previous file (increase in the number of files to GC) or not
        -- (same number of files to GC).
        [(FileId, FileInfo blk)]
filesToGC <- (OpenState blk h -> [(FileId, FileInfo blk)])
-> StateT
     (OpenState blk h)
     (WithTempRegistry (OpenState blk h) m)
     [(FileId, FileInfo blk)]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets OpenState blk h -> [(FileId, FileInfo blk)]
forall h. OpenState blk h -> [(FileId, FileInfo blk)]
getFilesToGC
        ((FileId, FileInfo blk) -> ModifyOpenState m blk h ())
-> [(FileId, FileInfo blk)] -> ModifyOpenState m blk h ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HasFS m h -> (FileId, FileInfo blk) -> ModifyOpenState m blk h ()
forall (m :: * -> *) h blk.
(MonadThrow m, HasHeader blk) =>
HasFS m h -> (FileId, FileInfo blk) -> ModifyOpenState m blk h ()
garbageCollectFile HasFS m h
hasFS) [(FileId, FileInfo blk)]
filesToGC
        -- Recompute the 'MaxSlotNo' based on the files left in the
        -- VolatileDB. This value can never go down, except to 'NoMaxSlotNo'
        -- (when we GC everything), because a GC can only delete blocks < a
        -- slot.
        (OpenState blk h -> OpenState blk h) -> ModifyOpenState m blk h ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((OpenState blk h -> OpenState blk h)
 -> ModifyOpenState m blk h ())
-> (OpenState blk h -> OpenState blk h)
-> ModifyOpenState m blk h ()
forall a b. (a -> b) -> a -> b
$ \OpenState blk h
st -> OpenState blk h
st {
            currentMaxSlotNo :: MaxSlotNo
currentMaxSlotNo = [FileInfo blk] -> MaxSlotNo
forall blk. [FileInfo blk] -> MaxSlotNo
FileInfo.maxSlotNoInFiles
                                 (Index blk -> [FileInfo blk]
forall blk. Index blk -> [FileInfo blk]
Index.elems (OpenState blk h -> Index blk
forall blk h. OpenState blk h -> Index blk
currentMap OpenState blk h
st))
          }
        WithTempRegistry (OpenState blk h) m ()
-> ModifyOpenState m blk h ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WithTempRegistry (OpenState blk h) m ()
 -> ModifyOpenState m blk h ())
-> WithTempRegistry (OpenState blk h) m ()
-> ModifyOpenState m blk h ()
forall a b. (a -> b) -> a -> b
$ m () -> WithTempRegistry (OpenState blk h) m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WithTempRegistry (OpenState blk h) m ())
-> m () -> WithTempRegistry (OpenState blk h) m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall (m :: * -> *). MonadEventlog m => String -> m ()
traceEventIO String
"STOP garbage collection"
  where
    -- | Return 'True' if a garbage collection would actually garbage collect
    -- at least one file.
    gcPossible :: OpenState blk h -> Bool
    gcPossible :: OpenState blk h -> Bool
gcPossible = Bool -> Bool
not (Bool -> Bool)
-> (OpenState blk h -> Bool) -> OpenState blk h -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FileId, FileInfo blk)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(FileId, FileInfo blk)] -> Bool)
-> (OpenState blk h -> [(FileId, FileInfo blk)])
-> OpenState blk h
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OpenState blk h -> [(FileId, FileInfo blk)]
forall h. OpenState blk h -> [(FileId, FileInfo blk)]
getFilesToGC

    -- | Return the list of files that can be garbage collected.
    getFilesToGC :: OpenState blk h -> [(FileId, FileInfo blk)]
    getFilesToGC :: OpenState blk h -> [(FileId, FileInfo blk)]
getFilesToGC OpenState blk h
st = ((FileId, FileInfo blk) -> Bool)
-> [(FileId, FileInfo blk)] -> [(FileId, FileInfo blk)]
forall a. (a -> Bool) -> [a] -> [a]
filter (FileId, FileInfo blk) -> Bool
canGC ([(FileId, FileInfo blk)] -> [(FileId, FileInfo blk)])
-> (OpenState blk h -> [(FileId, FileInfo blk)])
-> OpenState blk h
-> [(FileId, FileInfo blk)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index blk -> [(FileId, FileInfo blk)]
forall blk. Index blk -> [(FileId, FileInfo blk)]
Index.toAscList (Index blk -> [(FileId, FileInfo blk)])
-> (OpenState blk h -> Index blk)
-> OpenState blk h
-> [(FileId, FileInfo blk)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OpenState blk h -> Index blk
forall blk h. OpenState blk h -> Index blk
currentMap (OpenState blk h -> [(FileId, FileInfo blk)])
-> OpenState blk h -> [(FileId, FileInfo blk)]
forall a b. (a -> b) -> a -> b
$ OpenState blk h
st
      where
        -- We don't GC the current file. This is unlikely to happen in
        -- practice anyway, and it makes things simpler.
        canGC :: (FileId, FileInfo blk) -> Bool
canGC (FileId
fileId, FileInfo blk
fileInfo) =
          FileInfo blk -> SlotNo -> Bool
forall blk. FileInfo blk -> SlotNo -> Bool
FileInfo.canGC FileInfo blk
fileInfo SlotNo
slot Bool -> Bool -> Bool
&& FileId
fileId FileId -> FileId -> Bool
forall a. Eq a => a -> a -> Bool
/= OpenState blk h -> FileId
forall blk h. OpenState blk h -> FileId
currentWriteId OpenState blk h
st

-- | Garbage collect the given file /unconditionally/, updating the
-- 'OpenState'.
--
-- Important to note here is that, every call should leave the file system in
-- a consistent state, without depending on other calls. We achieve this by
-- only needed a single system call: 'removeFile'.
--
-- NOTE: the updated 'OpenState' is inconsistent in the follow respect:
-- the cached 'currentMaxSlotNo' hasn't been updated yet.
--
-- This may throw an FsError.
garbageCollectFile ::
     forall m h blk. (MonadThrow m, HasHeader blk)
  => HasFS m h
  -> (FileId, FileInfo blk)
  -> ModifyOpenState m blk h ()
garbageCollectFile :: HasFS m h -> (FileId, FileInfo blk) -> ModifyOpenState m blk h ()
garbageCollectFile HasFS m h
hasFS (FileId
fileId, FileInfo blk
fileInfo) = do

    WithTempRegistry (OpenState blk h) m ()
-> ModifyOpenState m blk h ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WithTempRegistry (OpenState blk h) m ()
 -> ModifyOpenState m blk h ())
-> WithTempRegistry (OpenState blk h) m ()
-> ModifyOpenState m blk h ()
forall a b. (a -> b) -> a -> b
$ m () -> WithTempRegistry (OpenState blk h) m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WithTempRegistry (OpenState blk h) m ())
-> m () -> WithTempRegistry (OpenState blk h) m ()
forall a b. (a -> b) -> a -> b
$ HasFS m h -> HasCallStack => FsPath -> m ()
forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
removeFile HasFS m h
hasFS (FsPath -> m ()) -> FsPath -> m ()
forall a b. (a -> b) -> a -> b
$ FileId -> FsPath
filePath FileId
fileId

    st :: OpenState blk h
st@OpenState { Index blk
currentMap :: Index blk
currentMap :: forall blk h. OpenState blk h -> Index blk
currentMap, ReverseIndex blk
currentRevMap :: ReverseIndex blk
currentRevMap :: forall blk h. OpenState blk h -> ReverseIndex blk
currentRevMap, SuccessorsIndex blk
currentSuccMap :: SuccessorsIndex blk
currentSuccMap :: forall blk h. OpenState blk h -> SuccessorsIndex blk
currentSuccMap } <- StateT
  (OpenState blk h)
  (WithTempRegistry (OpenState blk h) m)
  (OpenState blk h)
forall s (m :: * -> *). MonadState s m => m s
get

    let hashes :: Set (HeaderHash blk)
hashes          = FileInfo blk -> Set (HeaderHash blk)
forall blk. FileInfo blk -> Set (HeaderHash blk)
FileInfo.hashes FileInfo blk
fileInfo
        currentRevMap' :: ReverseIndex blk
currentRevMap'  = ReverseIndex blk -> Set (HeaderHash blk) -> ReverseIndex blk
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys ReverseIndex blk
currentRevMap Set (HeaderHash blk)
hashes
        deletedPairs :: [(ChainHash blk, HeaderHash blk)]
deletedPairs    =
          (HeaderHash blk -> Maybe (ChainHash blk, HeaderHash blk))
-> [HeaderHash blk] -> [(ChainHash blk, HeaderHash blk)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
            (\HeaderHash blk
h -> (, HeaderHash blk
h) (ChainHash blk -> (ChainHash blk, HeaderHash blk))
-> (InternalBlockInfo blk -> ChainHash blk)
-> InternalBlockInfo blk
-> (ChainHash blk, HeaderHash blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockInfo blk -> ChainHash blk
forall blk. BlockInfo blk -> ChainHash blk
biPrevHash (BlockInfo blk -> ChainHash blk)
-> (InternalBlockInfo blk -> BlockInfo blk)
-> InternalBlockInfo blk
-> ChainHash blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InternalBlockInfo blk -> BlockInfo blk
forall blk. InternalBlockInfo blk -> BlockInfo blk
ibiBlockInfo (InternalBlockInfo blk -> (ChainHash blk, HeaderHash blk))
-> Maybe (InternalBlockInfo blk)
-> Maybe (ChainHash blk, HeaderHash blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderHash blk -> ReverseIndex blk -> Maybe (InternalBlockInfo blk)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup HeaderHash blk
h ReverseIndex blk
currentRevMap)
            (Set (HeaderHash blk) -> [HeaderHash blk]
forall a. Set a -> [a]
Set.toList Set (HeaderHash blk)
hashes)
        currentSuccMap' :: SuccessorsIndex blk
currentSuccMap' =
          (SuccessorsIndex blk
 -> (ChainHash blk, HeaderHash blk) -> SuccessorsIndex blk)
-> SuccessorsIndex blk
-> [(ChainHash blk, HeaderHash blk)]
-> SuccessorsIndex blk
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (((ChainHash blk, HeaderHash blk)
 -> SuccessorsIndex blk -> SuccessorsIndex blk)
-> SuccessorsIndex blk
-> (ChainHash blk, HeaderHash blk)
-> SuccessorsIndex blk
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((ChainHash blk
 -> HeaderHash blk -> SuccessorsIndex blk -> SuccessorsIndex blk)
-> (ChainHash blk, HeaderHash blk)
-> SuccessorsIndex blk
-> SuccessorsIndex blk
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ChainHash blk
-> HeaderHash blk -> SuccessorsIndex blk -> SuccessorsIndex blk
forall k v.
(Ord k, Ord v) =>
k -> v -> Map k (Set v) -> Map k (Set v)
deleteMapSet)) SuccessorsIndex blk
currentSuccMap [(ChainHash blk, HeaderHash blk)]
deletedPairs

    OpenState blk h -> ModifyOpenState m blk h ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put OpenState blk h
st {
        currentMap :: Index blk
currentMap     = FileId -> Index blk -> Index blk
forall blk. FileId -> Index blk -> Index blk
Index.delete FileId
fileId Index blk
currentMap
      , currentRevMap :: ReverseIndex blk
currentRevMap  = ReverseIndex blk
currentRevMap'
      , currentSuccMap :: SuccessorsIndex blk
currentSuccMap = SuccessorsIndex blk
currentSuccMap'
      }

filterByPredecessorImpl ::
     forall m blk. (IOLike m, HasHeader blk)
  => VolatileDBEnv m blk
  -> STM m (ChainHash blk -> Set (HeaderHash blk))
filterByPredecessorImpl :: VolatileDBEnv m blk
-> STM m (ChainHash blk -> Set (HeaderHash blk))
filterByPredecessorImpl = (forall h.
 OpenState blk h -> ChainHash blk -> Set (HeaderHash blk))
-> VolatileDBEnv m blk
-> STM m (ChainHash blk -> Set (HeaderHash blk))
forall (m :: * -> *) blk a.
(IOLike m, HasHeader blk) =>
(forall h. OpenState blk h -> a) -> VolatileDBEnv m blk -> STM m a
getterSTM ((forall h.
  OpenState blk h -> ChainHash blk -> Set (HeaderHash blk))
 -> VolatileDBEnv m blk
 -> STM m (ChainHash blk -> Set (HeaderHash blk)))
-> (forall h.
    OpenState blk h -> ChainHash blk -> Set (HeaderHash blk))
-> VolatileDBEnv m blk
-> STM m (ChainHash blk -> Set (HeaderHash blk))
forall a b. (a -> b) -> a -> b
$ \OpenState blk h
st ChainHash blk
hash ->
    Set (HeaderHash blk)
-> Maybe (Set (HeaderHash blk)) -> Set (HeaderHash blk)
forall a. a -> Maybe a -> a
fromMaybe Set (HeaderHash blk)
forall a. Set a
Set.empty (ChainHash blk
-> Map (ChainHash blk) (Set (HeaderHash blk))
-> Maybe (Set (HeaderHash blk))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ChainHash blk
hash (OpenState blk h -> Map (ChainHash blk) (Set (HeaderHash blk))
forall blk h. OpenState blk h -> SuccessorsIndex blk
currentSuccMap OpenState blk h
st))

getBlockInfoImpl ::
     forall m blk. (IOLike m, HasHeader blk)
  => VolatileDBEnv m blk
  -> STM m (HeaderHash blk -> Maybe (BlockInfo blk))
getBlockInfoImpl :: VolatileDBEnv m blk
-> STM m (HeaderHash blk -> Maybe (BlockInfo blk))
getBlockInfoImpl = (forall h.
 OpenState blk h -> HeaderHash blk -> Maybe (BlockInfo blk))
-> VolatileDBEnv m blk
-> STM m (HeaderHash blk -> Maybe (BlockInfo blk))
forall (m :: * -> *) blk a.
(IOLike m, HasHeader blk) =>
(forall h. OpenState blk h -> a) -> VolatileDBEnv m blk -> STM m a
getterSTM ((forall h.
  OpenState blk h -> HeaderHash blk -> Maybe (BlockInfo blk))
 -> VolatileDBEnv m blk
 -> STM m (HeaderHash blk -> Maybe (BlockInfo blk)))
-> (forall h.
    OpenState blk h -> HeaderHash blk -> Maybe (BlockInfo blk))
-> VolatileDBEnv m blk
-> STM m (HeaderHash blk -> Maybe (BlockInfo blk))
forall a b. (a -> b) -> a -> b
$ \OpenState blk h
st HeaderHash blk
hash ->
    InternalBlockInfo blk -> BlockInfo blk
forall blk. InternalBlockInfo blk -> BlockInfo blk
ibiBlockInfo (InternalBlockInfo blk -> BlockInfo blk)
-> Maybe (InternalBlockInfo blk) -> Maybe (BlockInfo blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderHash blk
-> Map (HeaderHash blk) (InternalBlockInfo blk)
-> Maybe (InternalBlockInfo blk)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup HeaderHash blk
hash (OpenState blk h -> Map (HeaderHash blk) (InternalBlockInfo blk)
forall blk h. OpenState blk h -> ReverseIndex blk
currentRevMap OpenState blk h
st)

getMaxSlotNoImpl ::
     forall m blk. (IOLike m, HasHeader blk)
  => VolatileDBEnv m blk
  -> STM m MaxSlotNo
getMaxSlotNoImpl :: VolatileDBEnv m blk -> STM m MaxSlotNo
getMaxSlotNoImpl = (forall h. OpenState blk h -> MaxSlotNo)
-> VolatileDBEnv m blk -> STM m MaxSlotNo
forall (m :: * -> *) blk a.
(IOLike m, HasHeader blk) =>
(forall h. OpenState blk h -> a) -> VolatileDBEnv m blk -> STM m a
getterSTM forall h. OpenState blk h -> MaxSlotNo
forall blk h. OpenState blk h -> MaxSlotNo
currentMaxSlotNo

{------------------------------------------------------------------------------
  Internal functions
------------------------------------------------------------------------------}

-- | Creates a new file and updates the 'OpenState' accordingly.
-- This may throw an FsError.
nextFile ::
     forall h m blk. (IOLike m, Eq h)
  => HasFS m h -> ModifyOpenState m blk h ()
nextFile :: HasFS m h -> ModifyOpenState m blk h ()
nextFile HasFS m h
hasFS = do
    st :: OpenState blk h
st@OpenState { currentWriteHandle :: forall blk h. OpenState blk h -> Handle h
currentWriteHandle = Handle h
curHndl, FileId
currentWriteId :: FileId
currentWriteId :: forall blk h. OpenState blk h -> FileId
currentWriteId, Index blk
currentMap :: Index blk
currentMap :: forall blk h. OpenState blk h -> Index blk
currentMap } <- StateT
  (OpenState blk h)
  (WithTempRegistry (OpenState blk h) m)
  (OpenState blk h)
forall s (m :: * -> *). MonadState s m => m s
get

    let currentWriteId' :: FileId
currentWriteId' = FileId
currentWriteId FileId -> FileId -> FileId
forall a. Num a => a -> a -> a
+ FileId
1
        file :: FsPath
file = FileId -> FsPath
filePath FileId
currentWriteId'

    WithTempRegistry (OpenState blk h) m ()
-> ModifyOpenState m blk h ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WithTempRegistry (OpenState blk h) m ()
 -> ModifyOpenState m blk h ())
-> WithTempRegistry (OpenState blk h) m ()
-> ModifyOpenState m blk h ()
forall a b. (a -> b) -> a -> b
$ m () -> WithTempRegistry (OpenState blk h) m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WithTempRegistry (OpenState blk h) m ())
-> m () -> WithTempRegistry (OpenState blk h) m ()
forall a b. (a -> b) -> a -> b
$ HasFS m h -> Handle h -> m ()
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m ()
hClose HasFS m h
hasFS Handle h
curHndl

    Handle h
hndl <- WithTempRegistry (OpenState blk h) m (Handle h)
-> StateT
     (OpenState blk h) (WithTempRegistry (OpenState blk h) m) (Handle h)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WithTempRegistry (OpenState blk h) m (Handle h)
 -> StateT
      (OpenState blk h)
      (WithTempRegistry (OpenState blk h) m)
      (Handle h))
-> WithTempRegistry (OpenState blk h) m (Handle h)
-> StateT
     (OpenState blk h) (WithTempRegistry (OpenState blk h) m) (Handle h)
forall a b. (a -> b) -> a -> b
$ m (Handle h)
-> (Handle h -> m Bool)
-> (OpenState blk h -> Handle h -> Bool)
-> WithTempRegistry (OpenState blk h) m (Handle h)
forall (m :: * -> *) a st.
(IOLike m, HasCallStack) =>
m a
-> (a -> m Bool) -> (st -> a -> Bool) -> WithTempRegistry st m a
allocateTemp
      (HasFS m h -> FsPath -> OpenMode -> m (Handle h)
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> OpenMode -> m (Handle h)
hOpen   HasFS m h
hasFS FsPath
file (AllowExisting -> OpenMode
AppendMode AllowExisting
MustBeNew))
      (HasFS m h -> Handle h -> m Bool
forall (m :: * -> *) h.
(HasCallStack, Monad m) =>
HasFS m h -> Handle h -> m Bool
hClose' HasFS m h
hasFS)
      (Handle h -> Handle h -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Handle h -> Handle h -> Bool)
-> (OpenState blk h -> Handle h)
-> OpenState blk h
-> Handle h
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OpenState blk h -> Handle h
forall blk h. OpenState blk h -> Handle h
currentWriteHandle)
    OpenState blk h -> ModifyOpenState m blk h ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put OpenState blk h
st {
        currentWriteHandle :: Handle h
currentWriteHandle = Handle h
hndl
      , currentWritePath :: FsPath
currentWritePath   = FsPath
file
      , currentWriteId :: FileId
currentWriteId     = FileId
currentWriteId'
      , currentWriteOffset :: Word64
currentWriteOffset = Word64
0
      , currentMap :: Index blk
currentMap         = FileId -> FileInfo blk -> Index blk -> Index blk
forall blk. FileId -> FileInfo blk -> Index blk -> Index blk
Index.insert FileId
currentWriteId' FileInfo blk
forall blk. FileInfo blk
FileInfo.empty
                                Index blk
currentMap
      }

-- | Gets part of the 'OpenState' in 'STM'.
getterSTM ::
     forall m blk a. (IOLike m, HasHeader blk)
  => (forall h. OpenState blk h -> a)
  -> VolatileDBEnv m blk
  -> STM m a
getterSTM :: (forall h. OpenState blk h -> a) -> VolatileDBEnv m blk -> STM m a
getterSTM forall h. OpenState blk h -> a
fromSt VolatileDBEnv { RAWLock m (InternalState blk h)
varInternalState :: RAWLock m (InternalState blk h)
varInternalState :: ()
varInternalState } = do
    InternalState blk h
mSt <- RAWLock m (InternalState blk h) -> STM m (InternalState blk h)
forall (m :: * -> *) st. IOLike m => RAWLock m st -> STM m st
RAWLock.read RAWLock m (InternalState blk h)
varInternalState
    case InternalState blk h
mSt of
      InternalState blk h
DbClosed  -> VolatileDBError blk -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (VolatileDBError blk -> STM m a) -> VolatileDBError blk -> STM m a
forall a b. (a -> b) -> a -> b
$ ApiMisuse -> VolatileDBError blk
forall blk. ApiMisuse -> VolatileDBError blk
ApiMisuse @blk (ApiMisuse -> VolatileDBError blk)
-> ApiMisuse -> VolatileDBError blk
forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> ApiMisuse
ClosedDBError Maybe SomeException
forall a. Maybe a
Nothing
      DbOpen OpenState blk h
st -> a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> STM m a) -> a -> STM m a
forall a b. (a -> b) -> a -> b
$ OpenState blk h -> a
forall h. OpenState blk h -> a
fromSt OpenState blk h
st