{-# LANGUAGE DeriveAnyClass            #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE LambdaCase                #-}
{-# LANGUAGE NamedFieldPuns            #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE RecordWildCards           #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TypeApplications          #-}

module Ouroboros.Consensus.Storage.VolatileDB.Impl.State (
    -- * Tracing
    TraceEvent (..)
    -- * State types
  , BlockOffset (..)
  , BlockSize (..)
  , FileId
  , InternalState (..)
  , OpenState (..)
  , ReverseIndex
  , SuccessorsIndex
  , VolatileDBEnv (..)
  , dbIsOpen
    -- * State helpers
  , ModifyOpenState
  , appendOpenState
  , closeOpenHandles
  , mkOpenState
  , withOpenState
  , writeOpenState
  ) where

import           Control.Monad
import           Control.Monad.State.Strict hiding (withState)
import           Control.Tracer (Tracer, traceWith)
import qualified Data.ByteString.Lazy as Lazy
import           Data.List (foldl')
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import           Data.Typeable (Typeable)
import           Data.Word (Word64)
import           GHC.Generics (Generic)
import           GHC.Stack

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

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Util (whenJust, (.:))
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.MonadSTM.RAWLock (RAWLock)
import qualified Ouroboros.Consensus.Util.MonadSTM.RAWLock as RAWLock
import           Ouroboros.Consensus.Util.ResourceRegistry (WithTempRegistry,
                     allocateTemp, modifyWithTempRegistry)

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 qualified Ouroboros.Consensus.Storage.VolatileDB.Impl.FileInfo as FileInfo
import           Ouroboros.Consensus.Storage.VolatileDB.Impl.Index (Index)
import qualified Ouroboros.Consensus.Storage.VolatileDB.Impl.Index as Index
import           Ouroboros.Consensus.Storage.VolatileDB.Impl.Parser
import           Ouroboros.Consensus.Storage.VolatileDB.Impl.Types
import           Ouroboros.Consensus.Storage.VolatileDB.Impl.Util

{------------------------------------------------------------------------------
  State types
------------------------------------------------------------------------------}

data VolatileDBEnv m blk = forall h. Eq h => VolatileDBEnv {
      ()
hasFS            :: !(HasFS m h)
    , ()
varInternalState :: !(RAWLock m (InternalState blk h))
    , VolatileDBEnv m blk -> BlocksPerFile
maxBlocksPerFile :: !BlocksPerFile
    , VolatileDBEnv m blk -> blk -> Bool
checkIntegrity   :: !(blk -> Bool)
    , VolatileDBEnv m blk -> CodecConfig blk
codecConfig      :: !(CodecConfig blk)
    , VolatileDBEnv m blk -> Tracer m (TraceEvent blk)
tracer           :: !(Tracer m (TraceEvent blk))
    }

data InternalState blk h =
    DbClosed
  | DbOpen !(OpenState blk h)
  deriving ((forall x. InternalState blk h -> Rep (InternalState blk h) x)
-> (forall x. Rep (InternalState blk h) x -> InternalState blk h)
-> Generic (InternalState blk h)
forall x. Rep (InternalState blk h) x -> InternalState blk h
forall x. InternalState blk h -> Rep (InternalState blk h) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk h x. Rep (InternalState blk h) x -> InternalState blk h
forall blk h x. InternalState blk h -> Rep (InternalState blk h) x
$cto :: forall blk h x. Rep (InternalState blk h) x -> InternalState blk h
$cfrom :: forall blk h x. InternalState blk h -> Rep (InternalState blk h) x
Generic, Context -> InternalState blk h -> IO (Maybe ThunkInfo)
Proxy (InternalState blk h) -> String
(Context -> InternalState blk h -> IO (Maybe ThunkInfo))
-> (Context -> InternalState blk h -> IO (Maybe ThunkInfo))
-> (Proxy (InternalState blk h) -> String)
-> NoThunks (InternalState blk h)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall blk h.
(StandardHash blk, Typeable blk) =>
Context -> InternalState blk h -> IO (Maybe ThunkInfo)
forall blk h.
(StandardHash blk, Typeable blk) =>
Proxy (InternalState blk h) -> String
showTypeOf :: Proxy (InternalState blk h) -> String
$cshowTypeOf :: forall blk h.
(StandardHash blk, Typeable blk) =>
Proxy (InternalState blk h) -> String
wNoThunks :: Context -> InternalState blk h -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk h.
(StandardHash blk, Typeable blk) =>
Context -> InternalState blk h -> IO (Maybe ThunkInfo)
noThunks :: Context -> InternalState blk h -> IO (Maybe ThunkInfo)
$cnoThunks :: forall blk h.
(StandardHash blk, Typeable blk) =>
Context -> InternalState blk h -> IO (Maybe ThunkInfo)
NoThunks)

dbIsOpen :: InternalState blk h -> Bool
dbIsOpen :: InternalState blk h -> Bool
dbIsOpen (DbOpen OpenState blk h
_) = Bool
True
dbIsOpen InternalState blk h
DbClosed   = Bool
False

-- | Internal state when the database is open.
data OpenState blk h = OpenState {
      OpenState blk h -> Handle h
currentWriteHandle :: !(Handle h)
      -- ^ The only open file we append blocks to.
    , OpenState blk h -> FsPath
currentWritePath   :: !FsPath
      -- ^ The path of the file above.
    , OpenState blk h -> FileId
currentWriteId     :: !FileId
      -- ^ The 'FileId' of the same file.
    , OpenState blk h -> Word64
currentWriteOffset :: !Word64
      -- ^ The offset of the same file.
    , OpenState blk h -> Index blk
currentMap         :: !(Index blk)
      -- ^ The contents of each file.
    , OpenState blk h -> ReverseIndex blk
currentRevMap      :: !(ReverseIndex blk)
      -- ^ Where to find each block based on its slot number.
    , OpenState blk h -> SuccessorsIndex blk
currentSuccMap     :: !(SuccessorsIndex blk)
      -- ^ The successors for each block.
    , OpenState blk h -> MaxSlotNo
currentMaxSlotNo   :: !MaxSlotNo
      -- ^ Highest stored SlotNo.
      --
      -- INVARIANT: this is the cached value of:
      -- > FileInfo.maxSlotNoInFiles (Index.elems (currentMap st))
    }
  deriving ((forall x. OpenState blk h -> Rep (OpenState blk h) x)
-> (forall x. Rep (OpenState blk h) x -> OpenState blk h)
-> Generic (OpenState blk h)
forall x. Rep (OpenState blk h) x -> OpenState blk h
forall x. OpenState blk h -> Rep (OpenState blk h) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk h x. Rep (OpenState blk h) x -> OpenState blk h
forall blk h x. OpenState blk h -> Rep (OpenState blk h) x
$cto :: forall blk h x. Rep (OpenState blk h) x -> OpenState blk h
$cfrom :: forall blk h x. OpenState blk h -> Rep (OpenState blk h) x
Generic, Context -> OpenState blk h -> IO (Maybe ThunkInfo)
Proxy (OpenState blk h) -> String
(Context -> OpenState blk h -> IO (Maybe ThunkInfo))
-> (Context -> OpenState blk h -> IO (Maybe ThunkInfo))
-> (Proxy (OpenState blk h) -> String)
-> NoThunks (OpenState blk h)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall blk h.
(StandardHash blk, Typeable blk) =>
Context -> OpenState blk h -> IO (Maybe ThunkInfo)
forall blk h.
(StandardHash blk, Typeable blk) =>
Proxy (OpenState blk h) -> String
showTypeOf :: Proxy (OpenState blk h) -> String
$cshowTypeOf :: forall blk h.
(StandardHash blk, Typeable blk) =>
Proxy (OpenState blk h) -> String
wNoThunks :: Context -> OpenState blk h -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk h.
(StandardHash blk, Typeable blk) =>
Context -> OpenState blk h -> IO (Maybe ThunkInfo)
noThunks :: Context -> OpenState blk h -> IO (Maybe ThunkInfo)
$cnoThunks :: forall blk h.
(StandardHash blk, Typeable blk) =>
Context -> OpenState blk h -> IO (Maybe ThunkInfo)
NoThunks)

{------------------------------------------------------------------------------
  State helpers
------------------------------------------------------------------------------}

-- | Shorthand
type ModifyOpenState m blk h =
  StateT (OpenState blk h) (WithTempRegistry (OpenState blk h) m)

data AppendOrWrite = Append | Write

-- | NOTE: This is safe in terms of throwing FsErrors.
modifyOpenState ::
     forall blk m a. (IOLike m, HasCallStack, StandardHash blk, Typeable blk)
  => AppendOrWrite
  -> VolatileDBEnv m blk
  -> (forall h. Eq h => HasFS m h -> ModifyOpenState m blk h a)
  -> m a
modifyOpenState :: AppendOrWrite
-> VolatileDBEnv m blk
-> (forall h. Eq h => HasFS m h -> ModifyOpenState m blk h a)
-> m a
modifyOpenState AppendOrWrite
appendOrWrite
                VolatileDBEnv {hasFS :: ()
hasFS = HasFS m h
hasFS :: HasFS m h, RAWLock m (InternalState blk h)
varInternalState :: RAWLock m (InternalState blk h)
varInternalState :: ()
varInternalState}
                forall h. Eq h => HasFS m h -> ModifyOpenState m blk h a
modSt =
    Proxy blk -> m a -> m a
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 a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ m (OpenState blk h)
-> (OpenState blk h -> ExitCase (OpenState blk h) -> m ())
-> StateT
     (OpenState blk h) (WithTempRegistry (OpenState blk h) m) a
-> m a
forall (m :: * -> *) st a.
IOLike m =>
m st
-> (st -> ExitCase st -> m ())
-> StateT st (WithTempRegistry st m) a
-> m a
modifyWithTempRegistry m (OpenState blk h)
getSt OpenState blk h -> ExitCase (OpenState blk h) -> m ()
putSt (HasFS m h
-> StateT
     (OpenState blk h) (WithTempRegistry (OpenState blk h) m) a
forall h. Eq h => HasFS m h -> ModifyOpenState m blk h a
modSt HasFS m h
hasFS)
  where
    -- NOTE: we can't use the bracketed variants, as that's incompatible with
    -- 'modifyWithTempRegistry', which takes a function to put back the state,
    -- as that must have succeeded before the resources are released from the
    -- temporary registry.
    (RAWLock m a -> m a
acquire, RAWLock m st -> st -> m ()
release) = case AppendOrWrite
appendOrWrite of
      AppendOrWrite
Append ->
        (STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m a -> m a) -> (RAWLock m a -> STM m a) -> RAWLock m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  RAWLock m a -> STM m a
forall (m :: * -> *) st. IOLike m => RAWLock m st -> STM m st
RAWLock.unsafeAcquireAppendAccess,
         STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ())
-> (RAWLock m st -> st -> STM m ()) -> RAWLock m st -> st -> m ()
forall y z x0 x1. (y -> z) -> (x0 -> x1 -> y) -> x0 -> x1 -> z
.: RAWLock m st -> st -> STM m ()
forall (m :: * -> *) st. IOLike m => RAWLock m st -> st -> STM m ()
RAWLock.unsafeReleaseAppendAccess)
      AppendOrWrite
Write  ->
        (RAWLock m a -> m a
forall (m :: * -> *) st. IOLike m => RAWLock m st -> m st
RAWLock.unsafeAcquireWriteAccess, RAWLock m st -> st -> m ()
forall (m :: * -> *) st. IOLike m => RAWLock m st -> st -> m ()
RAWLock.unsafeReleaseWriteAccess)

    getSt :: m (OpenState blk h)
    getSt :: m (OpenState blk h)
getSt = RAWLock m (InternalState blk h) -> m (InternalState blk h)
forall a. RAWLock m a -> m a
acquire RAWLock m (InternalState blk h)
varInternalState m (InternalState blk h)
-> (InternalState blk h -> m (OpenState blk h))
-> m (OpenState blk h)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      DbOpen OpenState blk h
ost -> OpenState blk h -> m (OpenState blk h)
forall (m :: * -> *) a. Monad m => a -> m a
return OpenState blk h
ost
      InternalState blk h
DbClosed   -> do
        RAWLock m (InternalState blk h) -> InternalState blk h -> m ()
forall st. RAWLock m st -> st -> m ()
release RAWLock m (InternalState blk h)
varInternalState InternalState blk h
forall blk h. InternalState blk h
DbClosed
        VolatileDBError blk -> m (OpenState blk h)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (VolatileDBError blk -> m (OpenState blk h))
-> VolatileDBError blk -> m (OpenState blk h)
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

    putSt :: OpenState blk h -> ExitCase (OpenState blk h) -> m ()
    putSt :: OpenState blk h -> ExitCase (OpenState blk h) -> m ()
putSt OpenState blk h
ost ExitCase (OpenState blk h)
ec = case Either SomeException (OpenState blk h)
closeOrRelease of
        -- We must close the VolatileDB
        Left SomeException
ex -> do
          -- Poison the internal state lock with the exception that caused us
          -- to close the VolatileDB so the next time somebody accesses the
          -- VolatileDB, a 'ClosedDBError' containing the exception that
          -- caused it is thrown.
          --
          -- We don't care about the current state, as we were appending or
          -- writing, which means that the state couldn't have changed in the
          -- background.
          Maybe (InternalState blk h)
_mbCurState <-
            RAWLock m (InternalState blk h)
-> (CallStack -> VolatileDBError blk)
-> m (Maybe (InternalState blk h))
forall (m :: * -> *) e st.
(IOLike m, Exception e, HasCallStack) =>
RAWLock m st -> (CallStack -> e) -> m (Maybe st)
RAWLock.poison RAWLock m (InternalState blk h)
varInternalState ((CallStack -> VolatileDBError blk)
 -> m (Maybe (InternalState blk h)))
-> (CallStack -> VolatileDBError blk)
-> m (Maybe (InternalState blk h))
forall a b. (a -> b) -> a -> b
$ \CallStack
_st ->
              ApiMisuse -> VolatileDBError blk
forall blk. ApiMisuse -> VolatileDBError blk
ApiMisuse @blk (Maybe SomeException -> ApiMisuse
ClosedDBError (SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
ex))
          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
        Right OpenState blk h
ost' -> RAWLock m (InternalState blk h) -> InternalState blk h -> m ()
forall st. RAWLock m st -> st -> m ()
release RAWLock m (InternalState blk h)
varInternalState (OpenState blk h -> InternalState blk h
forall blk h. OpenState blk h -> InternalState blk h
DbOpen OpenState blk h
ost')
      where
        closeOrRelease :: Either SomeException (OpenState blk h)
        closeOrRelease :: Either SomeException (OpenState blk h)
closeOrRelease = case ExitCase (OpenState blk h)
ec of
          ExitCaseSuccess OpenState blk h
ost'
            -> OpenState blk h -> Either SomeException (OpenState blk h)
forall a b. b -> Either a b
Right OpenState blk h
ost'
          -- When something goes wrong, close the VolatileDB for safety.
          -- Except for user errors, because they stem from incorrect use of
          -- the VolatileDB.
          --
          -- NOTE: we only modify the VolatileDB in background threads of the
          -- ChainDB, not in per-connection threads that could be killed at
          -- any point. When an exception is encountered while modifying the
          -- VolatileDB in a background thread, or that background thread
          -- itself is killed with an async exception, we will shut down the
          -- node anway, so it is safe to close the VolatileDB here.
          ExitCase (OpenState blk h)
ExitCaseAbort
            -- Only caused by 'throwE' or 'throwError' like functions, which
            -- we don't use, but we use @IOLike m => m@ here.
            -> String -> Either SomeException (OpenState blk h)
forall a. HasCallStack => String -> a
error String
"impossible"
          ExitCaseException SomeException
ex
            | Just (ApiMisuse {} :: VolatileDBError blk) <- SomeException -> Maybe (VolatileDBError blk)
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex
            -> OpenState blk h -> Either SomeException (OpenState blk h)
forall a b. b -> Either a b
Right OpenState blk h
ost
            | Bool
otherwise
            -> SomeException -> Either SomeException (OpenState blk h)
forall a b. a -> Either a b
Left SomeException
ex

-- | Append to the open state. Reads can happen concurrently with this
-- operation.
--
-- NOTE: This is safe in terms of throwing FsErrors.
appendOpenState ::
     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
-> (forall h. Eq h => HasFS m h -> ModifyOpenState m blk h a)
-> m a
appendOpenState = AppendOrWrite
-> VolatileDBEnv m blk
-> (forall h. Eq h => HasFS m h -> ModifyOpenState m blk h a)
-> m a
forall blk (m :: * -> *) a.
(IOLike m, HasCallStack, StandardHash blk, Typeable blk) =>
AppendOrWrite
-> VolatileDBEnv m blk
-> (forall h. Eq h => HasFS m h -> ModifyOpenState m blk h a)
-> m a
modifyOpenState AppendOrWrite
Append

-- | Write to the open state. No reads or appends can concurrently with this
-- operation.
--
-- NOTE: This is safe in terms of throwing FsErrors.
writeOpenState ::
     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
-> (forall h. Eq h => HasFS m h -> ModifyOpenState m blk h a)
-> m a
writeOpenState = AppendOrWrite
-> VolatileDBEnv m blk
-> (forall h. Eq h => HasFS m h -> ModifyOpenState m blk h a)
-> m a
forall blk (m :: * -> *) a.
(IOLike m, HasCallStack, StandardHash blk, Typeable blk) =>
AppendOrWrite
-> VolatileDBEnv m blk
-> (forall h. Eq h => HasFS m h -> ModifyOpenState m blk h a)
-> m a
modifyOpenState AppendOrWrite
Write

-- | Perform an action that accesses the internal state of an open database.
--
-- In case the database is closed, a 'ClosedDBError' is thrown.
--
-- In case an 'UnexpectedFailure' is thrown while the action is being run, the
-- database is closed to prevent further appending to a database in a
-- potentially inconsistent state. All other exceptions will leave the database
-- open.
withOpenState ::
     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
-> (forall h. HasFS m h -> OpenState blk h -> m r) -> m r
withOpenState VolatileDBEnv {hasFS :: ()
hasFS = HasFS m h
hasFS :: HasFS m h, RAWLock m (InternalState blk h)
varInternalState :: RAWLock m (InternalState blk h)
varInternalState :: ()
varInternalState} forall h. HasFS m h -> OpenState blk h -> m r
action = do
    (Either (VolatileDBError blk) r
mr, ()) <- m (OpenState blk h)
-> (OpenState blk h
    -> ExitCase (Either (VolatileDBError blk) r) -> m ())
-> (OpenState blk h -> m (Either (VolatileDBError blk) r))
-> m (Either (VolatileDBError blk) r, ())
forall (m :: * -> *) a b c.
MonadCatch m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket m (OpenState blk h)
open OpenState blk h
-> ExitCase (Either (VolatileDBError blk) r) -> m ()
close (Proxy blk -> m r -> m (Either (VolatileDBError blk) r)
forall (m :: * -> *) a blk.
(MonadCatch m, Typeable blk, StandardHash blk) =>
Proxy blk -> m a -> m (Either (VolatileDBError blk) a)
tryVolatileDB (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk)(m r -> m (Either (VolatileDBError blk) r))
-> (OpenState blk h -> m r)
-> OpenState blk h
-> m (Either (VolatileDBError blk) r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OpenState blk h -> m r
access)
    case Either (VolatileDBError blk) r
mr of
      Left  VolatileDBError blk
e -> VolatileDBError blk -> m r
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO VolatileDBError blk
e
      Right r
r -> r -> m r
forall (m :: * -> *) a. Monad m => a -> m a
return r
r
  where
    open :: m (OpenState blk h)
    open :: m (OpenState blk h)
open =
      STM m (InternalState blk h) -> m (InternalState blk h)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (RAWLock m (InternalState blk h) -> STM m (InternalState blk h)
forall (m :: * -> *) st. IOLike m => RAWLock m st -> STM m st
RAWLock.unsafeAcquireReadAccess RAWLock m (InternalState blk h)
varInternalState) m (InternalState blk h)
-> (InternalState blk h -> m (OpenState blk h))
-> m (OpenState blk h)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        DbOpen OpenState blk h
ost -> OpenState blk h -> m (OpenState blk h)
forall (m :: * -> *) a. Monad m => a -> m a
return OpenState blk h
ost
        InternalState blk h
DbClosed   -> do
          STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ RAWLock m (InternalState blk h) -> STM m ()
forall (m :: * -> *) st. IOLike m => RAWLock m st -> STM m ()
RAWLock.unsafeReleaseReadAccess RAWLock m (InternalState blk h)
varInternalState
          VolatileDBError blk -> m (OpenState blk h)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (VolatileDBError blk -> m (OpenState blk h))
-> VolatileDBError blk -> m (OpenState blk h)
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

    close ::
         OpenState blk h
      -> ExitCase (Either (VolatileDBError blk) r)
      -> m ()
    close :: OpenState blk h
-> ExitCase (Either (VolatileDBError blk) r) -> m ()
close OpenState blk h
ost ExitCase (Either (VolatileDBError blk) r)
ec
        | Just SomeException
ex <- Maybe SomeException
shouldClose
        = do
            -- Poison the internal state lock with the exception that caused
            -- us to close the VolatileDB so the next time somebody accesses
            -- the VolatileDB, a 'ClosedDBError' containing the exception that
            -- caused it is thrown.
            Maybe (InternalState blk h)
mbCurState <-
              RAWLock m (InternalState blk h)
-> (CallStack -> VolatileDBError blk)
-> m (Maybe (InternalState blk h))
forall (m :: * -> *) e st.
(IOLike m, Exception e, HasCallStack) =>
RAWLock m st -> (CallStack -> e) -> m (Maybe st)
RAWLock.poison RAWLock m (InternalState blk h)
varInternalState ((CallStack -> VolatileDBError blk)
 -> m (Maybe (InternalState blk h)))
-> (CallStack -> VolatileDBError blk)
-> m (Maybe (InternalState blk h))
forall a b. (a -> b) -> a -> b
$ \CallStack
_st ->
                ApiMisuse -> VolatileDBError blk
forall blk. ApiMisuse -> VolatileDBError blk
ApiMisuse @blk (Maybe SomeException -> ApiMisuse
ClosedDBError (SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
ex))
            -- Close the open handles
            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
$ case Maybe (InternalState blk h)
mbCurState of
              -- The handles in the most recent state
              Just (DbOpen OpenState blk h
ost') -> 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'
              -- The state was already closed, which is always followed by
              -- closing the open handles, so nothing to do.
              Just InternalState blk h
DbClosed      -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              -- No current value, e.g., we interrupted a thread in a middle
              -- of a write. Close the last open handles we know about. The
              -- interrupted thread will clean up its own resources that
              -- haven't yet made it into the state (thanks to
              -- 'modifyWithTempRegistry').
              Maybe (InternalState blk h)
Nothing            -> 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

        | Bool
otherwise
        = STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ RAWLock m (InternalState blk h) -> STM m ()
forall (m :: * -> *) st. IOLike m => RAWLock m st -> STM m ()
RAWLock.unsafeReleaseReadAccess RAWLock m (InternalState blk h)
varInternalState
      where
        shouldClose :: Maybe SomeException
        shouldClose :: Maybe SomeException
shouldClose = case ExitCase (Either (VolatileDBError blk) r)
ec of
          ExitCase (Either (VolatileDBError blk) r)
ExitCaseAbort                                  -> Maybe SomeException
forall a. Maybe a
Nothing
          ExitCaseException SomeException
_ex                          -> Maybe SomeException
forall a. Maybe a
Nothing
          ExitCaseSuccess (Right r
_)                      -> Maybe SomeException
forall a. Maybe a
Nothing
          -- In case of a VolatileDBError, close when unexpected
          ExitCaseSuccess (Left ex :: VolatileDBError blk
ex@UnexpectedFailure {}) -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just (VolatileDBError blk -> SomeException
forall e. Exception e => e -> SomeException
toException VolatileDBError blk
ex)
          ExitCaseSuccess (Left ApiMisuse {})            -> Maybe SomeException
forall a. Maybe a
Nothing

    access :: OpenState blk h -> m r
    access :: OpenState blk h -> m r
access = HasFS m h -> OpenState blk h -> m r
forall h. HasFS m h -> OpenState blk h -> m r
action HasFS m h
hasFS

-- | Close the handles in the 'OpenState'.
--
-- Idempotent, as closing a handle is idempotent.
--
-- NOTE: does not wrap 'FsError's and must be called within 'wrapFsError' or
-- 'tryVolatileDB'.
closeOpenHandles :: HasFS m h -> OpenState blk h -> m ()
closeOpenHandles :: HasFS m h -> OpenState blk h -> m ()
closeOpenHandles HasFS { HasCallStack => Handle h -> m ()
hClose :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m ()
hClose :: HasCallStack => Handle h -> m ()
hClose } OpenState { Handle h
currentWriteHandle :: Handle h
currentWriteHandle :: forall blk h. OpenState blk h -> Handle h
currentWriteHandle } =
    HasCallStack => Handle h -> m ()
Handle h -> m ()
hClose Handle h
currentWriteHandle

mkOpenState ::
     forall m blk h.
     ( HasCallStack
     , IOLike m
     , GetPrevHash blk
     , HasBinaryBlockInfo blk
     , HasNestedContent Header blk
     , DecodeDisk blk (Lazy.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 :: CodecConfig blk
-> HasFS m h
-> (blk -> Bool)
-> BlockValidationPolicy
-> Tracer m (TraceEvent blk)
-> BlocksPerFile
-> WithTempRegistry (OpenState blk h) m (OpenState blk h)
mkOpenState CodecConfig blk
ccfg hasFS :: HasFS m h
hasFS@HasFS{m String
HasCallStack => Bool -> FsPath -> m ()
HasCallStack => Handle h -> m Bool
HasCallStack => Handle h -> m Word64
HasCallStack => Handle h -> m ()
HasCallStack => Handle h -> Word64 -> m ()
HasCallStack => Handle h -> Word64 -> m ByteString
HasCallStack => Handle h -> Word64 -> AbsOffset -> m ByteString
HasCallStack => Handle h -> ByteString -> m Word64
HasCallStack => Handle h -> SeekMode -> Int64 -> m ()
HasCallStack => FsPath -> m Bool
HasCallStack => FsPath -> m ()
HasCallStack => FsPath -> m (Set String)
HasCallStack => FsPath -> FsPath -> m ()
HasCallStack => FsPath -> OpenMode -> m (Handle h)
FsPath -> FsErrorPath
mkFsErrorPath :: forall (m :: * -> *) h. HasFS m h -> FsPath -> FsErrorPath
renameFile :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> FsPath -> m ()
removeFile :: forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
doesFileExist :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesDirectoryExist :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
listDirectory :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m (Set String)
createDirectoryIfMissing :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Bool -> FsPath -> m ()
createDirectory :: forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
hGetSize :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m Word64
hTruncate :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> Word64 -> m ()
hPutSome :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> ByteString -> m Word64
hGetSomeAt :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack => Handle h -> Word64 -> AbsOffset -> m ByteString
hGetSome :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> Word64 -> m ByteString
hSeek :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> SeekMode -> Int64 -> m ()
hIsOpen :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m Bool
hOpen :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> OpenMode -> m (Handle h)
dumpState :: forall (m :: * -> *) h. HasFS m h -> m String
mkFsErrorPath :: FsPath -> FsErrorPath
renameFile :: HasCallStack => FsPath -> FsPath -> m ()
removeFile :: HasCallStack => FsPath -> m ()
doesFileExist :: HasCallStack => FsPath -> m Bool
doesDirectoryExist :: HasCallStack => FsPath -> m Bool
listDirectory :: HasCallStack => FsPath -> m (Set String)
createDirectoryIfMissing :: HasCallStack => Bool -> FsPath -> m ()
createDirectory :: HasCallStack => FsPath -> m ()
hGetSize :: HasCallStack => Handle h -> m Word64
hTruncate :: HasCallStack => Handle h -> Word64 -> m ()
hPutSome :: HasCallStack => Handle h -> ByteString -> m Word64
hGetSomeAt :: HasCallStack => Handle h -> Word64 -> AbsOffset -> m ByteString
hGetSome :: HasCallStack => Handle h -> Word64 -> m ByteString
hSeek :: HasCallStack => Handle h -> SeekMode -> Int64 -> m ()
hIsOpen :: HasCallStack => Handle h -> m Bool
hClose :: HasCallStack => Handle h -> m ()
hOpen :: HasCallStack => FsPath -> OpenMode -> m (Handle h)
dumpState :: m String
hClose :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m ()
..} blk -> Bool
checkInvariants BlockValidationPolicy
validationPolicy Tracer m (TraceEvent blk)
tracer BlocksPerFile
maxBlocksPerFile = 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
$ HasCallStack => Bool -> FsPath -> m ()
Bool -> FsPath -> m ()
createDirectoryIfMissing Bool
True FsPath
dbDir
    [FsPath]
allFiles <- (String -> FsPath) -> Context -> [FsPath]
forall a b. (a -> b) -> [a] -> [b]
map String -> FsPath
toFsPath (Context -> [FsPath])
-> (Set String -> Context) -> Set String -> [FsPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set String -> Context
forall a. Set a -> [a]
Set.toList (Set String -> [FsPath])
-> WithTempRegistry (OpenState blk h) m (Set String)
-> WithTempRegistry (OpenState blk h) m [FsPath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Set String) -> WithTempRegistry (OpenState blk h) m (Set String)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (HasCallStack => FsPath -> m (Set String)
FsPath -> m (Set String)
listDirectory FsPath
dbDir)
    [(FileId, FsPath)]
filesWithIds <- m [(FileId, FsPath)]
-> WithTempRegistry (OpenState blk h) m [(FileId, FsPath)]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [(FileId, FsPath)]
 -> WithTempRegistry (OpenState blk h) m [(FileId, FsPath)])
-> m [(FileId, FsPath)]
-> WithTempRegistry (OpenState blk h) m [(FileId, FsPath)]
forall a b. (a -> b) -> a -> b
$ ([(FileId, FsPath)], [FsPath]) -> m [(FileId, FsPath)]
logInvalidFiles (([(FileId, FsPath)], [FsPath]) -> m [(FileId, FsPath)])
-> ([(FileId, FsPath)], [FsPath]) -> m [(FileId, FsPath)]
forall a b. (a -> b) -> a -> b
$ [FsPath] -> ([(FileId, FsPath)], [FsPath])
parseAllFds [FsPath]
allFiles
    CodecConfig blk
-> HasFS m h
-> (blk -> Bool)
-> BlockValidationPolicy
-> Tracer m (TraceEvent blk)
-> BlocksPerFile
-> [(FileId, FsPath)]
-> WithTempRegistry (OpenState blk h) m (OpenState blk h)
forall blk (m :: * -> *) h.
(HasCallStack, IOLike m, HasHeader blk, 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
-> [(FileId, FsPath)]
-> WithTempRegistry (OpenState blk h) m (OpenState blk h)
mkOpenStateHelper
      CodecConfig blk
ccfg
      HasFS m h
hasFS
      blk -> Bool
checkInvariants
      BlockValidationPolicy
validationPolicy
      Tracer m (TraceEvent blk)
tracer
      BlocksPerFile
maxBlocksPerFile
      [(FileId, FsPath)]
filesWithIds
  where
    -- | Logs about any invalid 'FsPath' and returns the valid ones.
    logInvalidFiles :: ([(FileId, FsPath)], [FsPath]) -> m [(FileId, FsPath)]
    logInvalidFiles :: ([(FileId, FsPath)], [FsPath]) -> m [(FileId, FsPath)]
logInvalidFiles ([(FileId, FsPath)]
valid, [FsPath]
invalid) = do
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([FsPath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FsPath]
invalid) (m () -> m ()) -> m () -> 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
$ [FsPath] -> TraceEvent blk
forall blk. [FsPath] -> TraceEvent blk
InvalidFileNames [FsPath]
invalid
      [(FileId, FsPath)] -> m [(FileId, FsPath)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(FileId, FsPath)]
valid

    dbDir :: FsPath
dbDir = Context -> FsPath
mkFsPath []

    toFsPath :: String -> FsPath
    toFsPath :: String -> FsPath
toFsPath String
file = Context -> FsPath
mkFsPath [String
file]

-- | Short-hand for all three index types
type Indices blk =
  ( Index           blk
  , ReverseIndex    blk
  , SuccessorsIndex blk
  )

-- | Make the 'OpenState' by parsing all files.
--
-- It may create a new file to append new blocks to or use an existing one.
mkOpenStateHelper ::
     forall blk m h.
     ( HasCallStack
     , IOLike m
     , HasHeader blk
     , GetPrevHash blk
     , HasBinaryBlockInfo blk
     , HasNestedContent Header blk
     , DecodeDisk blk (Lazy.ByteString -> blk)
     , Eq h
     )
  => CodecConfig blk
  -> HasFS m h
  -> (blk -> Bool)
  -> BlockValidationPolicy
  -> Tracer m (TraceEvent blk)
  -> BlocksPerFile
  -> [(FileId, FsPath)]
  -> WithTempRegistry (OpenState blk h) m (OpenState blk h)
mkOpenStateHelper :: CodecConfig blk
-> HasFS m h
-> (blk -> Bool)
-> BlockValidationPolicy
-> Tracer m (TraceEvent blk)
-> BlocksPerFile
-> [(FileId, FsPath)]
-> WithTempRegistry (OpenState blk h) m (OpenState blk h)
mkOpenStateHelper CodecConfig blk
ccfg HasFS m h
hasFS blk -> Bool
checkIntegrity BlockValidationPolicy
validationPolicy Tracer m (TraceEvent blk)
tracer BlocksPerFile
maxBlocksPerFile [(FileId, FsPath)]
files = do
    (Index blk
currentMap', Map (HeaderHash blk) (InternalBlockInfo blk)
currentRevMap', Map (ChainHash blk) (Set (HeaderHash blk))
currentSuccMap') <- m (Index blk, Map (HeaderHash blk) (InternalBlockInfo blk),
   Map (ChainHash blk) (Set (HeaderHash blk)))
-> WithTempRegistry
     (OpenState blk h)
     m
     (Index blk, Map (HeaderHash blk) (InternalBlockInfo blk),
      Map (ChainHash blk) (Set (HeaderHash blk)))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Index blk, Map (HeaderHash blk) (InternalBlockInfo blk),
    Map (ChainHash blk) (Set (HeaderHash blk)))
 -> WithTempRegistry
      (OpenState blk h)
      m
      (Index blk, Map (HeaderHash blk) (InternalBlockInfo blk),
       Map (ChainHash blk) (Set (HeaderHash blk))))
-> m (Index blk, Map (HeaderHash blk) (InternalBlockInfo blk),
      Map (ChainHash blk) (Set (HeaderHash blk)))
-> WithTempRegistry
     (OpenState blk h)
     m
     (Index blk, Map (HeaderHash blk) (InternalBlockInfo blk),
      Map (ChainHash blk) (Set (HeaderHash blk)))
forall a b. (a -> b) -> a -> b
$
      ((Index blk, Map (HeaderHash blk) (InternalBlockInfo blk),
  Map (ChainHash blk) (Set (HeaderHash blk)))
 -> (FileId, FsPath)
 -> m (Index blk, Map (HeaderHash blk) (InternalBlockInfo blk),
       Map (ChainHash blk) (Set (HeaderHash blk))))
-> (Index blk, Map (HeaderHash blk) (InternalBlockInfo blk),
    Map (ChainHash blk) (Set (HeaderHash blk)))
-> [(FileId, FsPath)]
-> m (Index blk, Map (HeaderHash blk) (InternalBlockInfo blk),
      Map (ChainHash blk) (Set (HeaderHash blk)))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Index blk, Map (HeaderHash blk) (InternalBlockInfo blk),
 Map (ChainHash blk) (Set (HeaderHash blk)))
-> (FileId, FsPath)
-> m (Index blk, Map (HeaderHash blk) (InternalBlockInfo blk),
      Map (ChainHash blk) (Set (HeaderHash blk)))
validateFile (Index blk
forall blk. Index blk
Index.empty, Map (HeaderHash blk) (InternalBlockInfo blk)
forall k a. Map k a
Map.empty, Map (ChainHash blk) (Set (HeaderHash blk))
forall k a. Map k a
Map.empty) [(FileId, FsPath)]
files

    let (FileId
currentWriteId, Index blk
currentMap'') = case Index blk -> Maybe (FileId, FileInfo blk)
forall blk. Index blk -> Maybe (FileId, FileInfo blk)
Index.lastFile Index blk
currentMap' of
          -- The DB is empty. Create a new file with 'FileId' 0
          Maybe (FileId, FileInfo blk)
Nothing
            -> (FileId
0, FileId -> FileInfo blk -> Index blk -> Index blk
forall blk. FileId -> FileInfo blk -> Index blk -> Index blk
Index.insert FileId
0 FileInfo blk
forall blk. FileInfo blk
FileInfo.empty Index blk
currentMap')
          Just (FileId
lastWriteId, FileInfo blk
lastFileInfo)
            | BlocksPerFile -> FileInfo blk -> Bool
forall blk. BlocksPerFile -> FileInfo blk -> Bool
FileInfo.isFull BlocksPerFile
maxBlocksPerFile FileInfo blk
lastFileInfo
            , let nextWriteId :: FileId
nextWriteId = FileId
lastWriteId FileId -> FileId -> FileId
forall a. Num a => a -> a -> a
+ FileId
1
              -- If the last file is full, we need to create a new one
            -> (FileId
nextWriteId, FileId -> FileInfo blk -> Index blk -> Index blk
forall blk. FileId -> FileInfo blk -> Index blk -> Index blk
Index.insert FileId
nextWriteId FileInfo blk
forall blk. FileInfo blk
FileInfo.empty Index blk
currentMap')
            | Bool
otherwise
              -- If the last file is not full, then use that one
            -> (FileId
lastWriteId, Index blk
currentMap')

    let currentWritePath :: FsPath
currentWritePath = FileId -> FsPath
filePath FileId
currentWriteId

    Handle h
currentWriteHandle <-
      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
currentWritePath (AllowExisting -> OpenMode
AppendMode AllowExisting
AllowExisting))
        (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)
    Word64
currentWriteOffset <- 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 -> m Word64
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m Word64
hGetSize HasFS m h
hasFS Handle h
currentWriteHandle

    OpenState blk h
-> WithTempRegistry (OpenState blk h) m (OpenState blk h)
forall (m :: * -> *) a. Monad m => a -> m a
return OpenState :: forall blk h.
Handle h
-> FsPath
-> FileId
-> Word64
-> Index blk
-> ReverseIndex blk
-> SuccessorsIndex blk
-> MaxSlotNo
-> OpenState blk h
OpenState {
        currentWriteHandle :: Handle h
currentWriteHandle = Handle h
currentWriteHandle
      , currentWritePath :: FsPath
currentWritePath   = FsPath
currentWritePath
      , currentWriteId :: FileId
currentWriteId     = FileId
currentWriteId
      , currentWriteOffset :: Word64
currentWriteOffset = Word64
currentWriteOffset
      , currentMap :: Index blk
currentMap         = Index blk
currentMap''
      , currentRevMap :: Map (HeaderHash blk) (InternalBlockInfo blk)
currentRevMap      = Map (HeaderHash blk) (InternalBlockInfo blk)
currentRevMap'
      , currentSuccMap :: Map (ChainHash blk) (Set (HeaderHash blk))
currentSuccMap     = Map (ChainHash blk) (Set (HeaderHash blk))
currentSuccMap'
      , 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 Index blk
currentMap')
      }
  where
    validateFile :: Indices blk -> (FileId, FsPath) -> m (Indices blk)
    validateFile :: (Index blk, Map (HeaderHash blk) (InternalBlockInfo blk),
 Map (ChainHash blk) (Set (HeaderHash blk)))
-> (FileId, FsPath)
-> m (Index blk, Map (HeaderHash blk) (InternalBlockInfo blk),
      Map (ChainHash blk) (Set (HeaderHash blk)))
validateFile (Index blk
currentMap, Map (HeaderHash blk) (InternalBlockInfo blk)
currentRevMap, Map (ChainHash blk) (Set (HeaderHash blk))
currentSuccMap) (FileId
fd, FsPath
file) = do
      ([ParsedBlockInfo blk]
parsedBlocks, Maybe (ParseError blk, BlockOffset)
mErr) <-
        CodecConfig blk
-> HasFS m h
-> (blk -> Bool)
-> BlockValidationPolicy
-> FsPath
-> m ([ParsedBlockInfo blk], Maybe (ParseError blk, BlockOffset))
forall (m :: * -> *) blk h.
(IOLike m, GetPrevHash blk, HasBinaryBlockInfo blk,
 HasNestedContent Header blk, DecodeDisk blk (ByteString -> blk)) =>
CodecConfig blk
-> HasFS m h
-> (blk -> Bool)
-> BlockValidationPolicy
-> FsPath
-> m ([ParsedBlockInfo blk], Maybe (ParseError blk, BlockOffset))
parseBlockFile CodecConfig blk
ccfg HasFS m h
hasFS blk -> Bool
checkIntegrity BlockValidationPolicy
validationPolicy FsPath
file
      Maybe (ParseError blk, BlockOffset)
-> ((ParseError blk, BlockOffset) -> m ()) -> m ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe (ParseError blk, BlockOffset)
mErr (((ParseError blk, BlockOffset) -> m ()) -> m ())
-> ((ParseError blk, BlockOffset) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(ParseError blk
e, BlockOffset
offset) ->
        FsPath -> ParseError blk -> BlockOffset -> m ()
truncateError FsPath
file ParseError blk
e BlockOffset
offset

      let (Map (HeaderHash blk) (InternalBlockInfo blk)
currentRevMap', [ParsedBlockInfo blk]
acceptedBlocks, Maybe (ParseError blk, BlockOffset)
mErr') =
            FsPath
-> Map (HeaderHash blk) (InternalBlockInfo blk)
-> [ParsedBlockInfo blk]
-> (Map (HeaderHash blk) (InternalBlockInfo blk),
    [ParsedBlockInfo blk], Maybe (ParseError blk, BlockOffset))
forall blk.
HasHeader blk =>
FsPath
-> ReverseIndex blk
-> [ParsedBlockInfo blk]
-> (ReverseIndex blk, [ParsedBlockInfo blk],
    Maybe (ParseError blk, BlockOffset))
addToReverseIndex FsPath
file Map (HeaderHash blk) (InternalBlockInfo blk)
currentRevMap [ParsedBlockInfo blk]
parsedBlocks
      -- We can find duplicate blocks when merging the parsed blocks with the
      -- 'ReverseIndex', so we might have to truncate at this point too.
      Maybe (ParseError blk, BlockOffset)
-> ((ParseError blk, BlockOffset) -> m ()) -> m ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe (ParseError blk, BlockOffset)
mErr' (((ParseError blk, BlockOffset) -> m ()) -> m ())
-> ((ParseError blk, BlockOffset) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(ParseError blk
e, BlockOffset
offset) ->
        FsPath -> ParseError blk -> BlockOffset -> m ()
truncateError FsPath
file ParseError blk
e BlockOffset
offset

      let fileInfo :: FileInfo blk
fileInfo        = [ParsedBlockInfo blk] -> FileInfo blk
forall blk.
StandardHash blk =>
[ParsedBlockInfo blk] -> FileInfo blk
FileInfo.fromParsedBlockInfos [ParsedBlockInfo blk]
acceptedBlocks
          currentMap' :: Index blk
currentMap'     = FileId -> FileInfo blk -> Index blk -> Index blk
forall blk. FileId -> FileInfo blk -> Index blk -> Index blk
Index.insert FileId
fd FileInfo blk
fileInfo Index blk
currentMap
          currentSuccMap' :: Map (ChainHash blk) (Set (HeaderHash blk))
currentSuccMap' = (Map (ChainHash blk) (Set (HeaderHash blk))
 -> ParsedBlockInfo blk
 -> Map (ChainHash blk) (Set (HeaderHash blk)))
-> Map (ChainHash blk) (Set (HeaderHash blk))
-> [ParsedBlockInfo blk]
-> Map (ChainHash blk) (Set (HeaderHash blk))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
            (\Map (ChainHash blk) (Set (HeaderHash blk))
succMap ParsedBlockInfo { BlockInfo blk
pbiBlockInfo :: forall blk. ParsedBlockInfo blk -> BlockInfo blk
pbiBlockInfo :: BlockInfo blk
pbiBlockInfo } ->
              ChainHash blk
-> HeaderHash blk
-> Map (ChainHash blk) (Set (HeaderHash blk))
-> Map (ChainHash blk) (Set (HeaderHash blk))
forall k v.
(Ord k, Ord v) =>
k -> v -> Map k (Set v) -> Map k (Set v)
insertMapSet (BlockInfo blk -> ChainHash blk
forall blk. BlockInfo blk -> ChainHash blk
biPrevHash BlockInfo blk
pbiBlockInfo) (BlockInfo blk -> HeaderHash blk
forall blk. BlockInfo blk -> HeaderHash blk
biHash BlockInfo blk
pbiBlockInfo) Map (ChainHash blk) (Set (HeaderHash blk))
succMap)
            Map (ChainHash blk) (Set (HeaderHash blk))
currentSuccMap
            [ParsedBlockInfo blk]
acceptedBlocks

      (Index blk, Map (HeaderHash blk) (InternalBlockInfo blk),
 Map (ChainHash blk) (Set (HeaderHash blk)))
-> m (Index blk, Map (HeaderHash blk) (InternalBlockInfo blk),
      Map (ChainHash blk) (Set (HeaderHash blk)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Index blk
currentMap', Map (HeaderHash blk) (InternalBlockInfo blk)
currentRevMap', Map (ChainHash blk) (Set (HeaderHash blk))
currentSuccMap')

    truncateError :: FsPath -> ParseError blk -> BlockOffset -> m ()
    truncateError :: FsPath -> ParseError blk -> BlockOffset -> m ()
truncateError FsPath
file ParseError blk
e BlockOffset
offset = do
      Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer (TraceEvent blk -> m ()) -> TraceEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ ParseError blk -> FsPath -> BlockOffset -> TraceEvent blk
forall blk.
ParseError blk -> FsPath -> BlockOffset -> TraceEvent blk
Truncate ParseError blk
e FsPath
file BlockOffset
offset
      -- The handle of the parser is closed at this point. We need
      -- to reopen the file in 'AppendMode' now (parser opens with
      -- 'ReadMode').
      --
      -- Note that no file is open at this point, so we can safely
      -- open with 'AppendMode' any file, without the fear of opening
      -- multiple concurrent writers, which is not allowed, or concurrent
      -- read with truncate.
      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
file (AllowExisting -> OpenMode
AppendMode AllowExisting
AllowExisting) ((Handle h -> m ()) -> m ()) -> (Handle h -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Handle h
hndl ->
        HasFS m h -> Handle h -> Word64 -> m ()
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> Word64 -> m ()
hTruncate HasFS m h
hasFS Handle h
hndl (BlockOffset -> Word64
unBlockOffset BlockOffset
offset)

-- | For each block found in a parsed file, we insert its 'InternalBlockInfo'
-- in the 'ReverseIndex'.
--
-- If a block is already present in the 'ReverseIndex' or occurs twice in the
-- same file, we stop with an error.
--
-- We return:
--
-- * A 'ReverseIndex' updated with the valid blocks
-- * A list of the valid blocks in the parsed file. This will be a prefix of
--   the given list, or most often, the original input list.
-- * In case of an error, the error and the offset to truncate to.
addToReverseIndex ::
     forall blk. HasHeader blk
  => FsPath
  -> ReverseIndex blk
  -> [ParsedBlockInfo blk]
  -> ( ReverseIndex blk
     , [ParsedBlockInfo blk]
     , Maybe (ParseError blk, BlockOffset)
     )
addToReverseIndex :: FsPath
-> ReverseIndex blk
-> [ParsedBlockInfo blk]
-> (ReverseIndex blk, [ParsedBlockInfo blk],
    Maybe (ParseError blk, BlockOffset))
addToReverseIndex FsPath
file = \ReverseIndex blk
revMap -> ReverseIndex blk
-> [ParsedBlockInfo blk]
-> [ParsedBlockInfo blk]
-> (ReverseIndex blk, [ParsedBlockInfo blk],
    Maybe (ParseError blk, BlockOffset))
go ReverseIndex blk
revMap []
  where
    go ::
         ReverseIndex blk
      -> [ParsedBlockInfo blk] -- accumulator of the accepted blocks.
      -> [ParsedBlockInfo blk]
      -> ( ReverseIndex blk
         , [ParsedBlockInfo blk]
         , Maybe (ParseError blk, BlockOffset)
         )
    go :: ReverseIndex blk
-> [ParsedBlockInfo blk]
-> [ParsedBlockInfo blk]
-> (ReverseIndex blk, [ParsedBlockInfo blk],
    Maybe (ParseError blk, BlockOffset))
go ReverseIndex blk
revMap [ParsedBlockInfo blk]
acc = \case
      []               -> (ReverseIndex blk
revMap, [ParsedBlockInfo blk] -> [ParsedBlockInfo blk]
forall a. [a] -> [a]
reverse [ParsedBlockInfo blk]
acc, Maybe (ParseError blk, BlockOffset)
forall a. Maybe a
Nothing)
      ParsedBlockInfo blk
parsedBlock:[ParsedBlockInfo blk]
rest -> case HeaderHash blk
-> InternalBlockInfo blk
-> ReverseIndex blk
-> Either (InternalBlockInfo blk) (ReverseIndex blk)
forall k a. Ord k => k -> a -> Map k a -> Either a (Map k a)
insertNew HeaderHash blk
biHash InternalBlockInfo blk
internalBlockInfo ReverseIndex blk
revMap of
          Right ReverseIndex blk
revMap' -> ReverseIndex blk
-> [ParsedBlockInfo blk]
-> [ParsedBlockInfo blk]
-> (ReverseIndex blk, [ParsedBlockInfo blk],
    Maybe (ParseError blk, BlockOffset))
go ReverseIndex blk
revMap' (ParsedBlockInfo blk
parsedBlockParsedBlockInfo blk
-> [ParsedBlockInfo blk] -> [ParsedBlockInfo blk]
forall a. a -> [a] -> [a]
:[ParsedBlockInfo blk]
acc) [ParsedBlockInfo blk]
rest
          Left InternalBlockInfo { ibiFile :: forall blk. InternalBlockInfo blk -> FsPath
ibiFile = FsPath
alreadyExistsHere } ->
              ( ReverseIndex blk
revMap
              , [ParsedBlockInfo blk] -> [ParsedBlockInfo blk]
forall a. [a] -> [a]
reverse [ParsedBlockInfo blk]
acc
              , (ParseError blk, BlockOffset)
-> Maybe (ParseError blk, BlockOffset)
forall a. a -> Maybe a
Just (HeaderHash blk -> FsPath -> FsPath -> ParseError blk
forall blk. HeaderHash blk -> FsPath -> FsPath -> ParseError blk
DuplicatedBlock HeaderHash blk
biHash FsPath
alreadyExistsHere FsPath
file, BlockOffset
offset)
              )
        where
          ParsedBlockInfo {
              pbiBlockOffset :: forall blk. ParsedBlockInfo blk -> BlockOffset
pbiBlockOffset = BlockOffset
offset
            , pbiBlockSize :: forall blk. ParsedBlockInfo blk -> BlockSize
pbiBlockSize   = BlockSize
size
            , pbiBlockInfo :: forall blk. ParsedBlockInfo blk -> BlockInfo blk
pbiBlockInfo   = blockInfo :: BlockInfo blk
blockInfo@BlockInfo { HeaderHash blk
biHash :: HeaderHash blk
biHash :: forall blk. BlockInfo blk -> HeaderHash blk
biHash }
            , pbiNestedCtxt :: forall blk.
ParsedBlockInfo blk -> SomeSecond (NestedCtxt Header) blk
pbiNestedCtxt  = SomeSecond (NestedCtxt Header) blk
nestedCtxt
            } = ParsedBlockInfo blk
parsedBlock
          internalBlockInfo :: InternalBlockInfo blk
internalBlockInfo = InternalBlockInfo :: forall blk.
FsPath
-> BlockOffset
-> BlockSize
-> BlockInfo blk
-> SomeSecond (NestedCtxt Header) blk
-> InternalBlockInfo blk
InternalBlockInfo {
              ibiFile :: FsPath
ibiFile         = FsPath
file
            , ibiBlockOffset :: BlockOffset
ibiBlockOffset  = BlockOffset
offset
            , ibiBlockSize :: BlockSize
ibiBlockSize    = BlockSize
size
            , ibiBlockInfo :: BlockInfo blk
ibiBlockInfo    = BlockInfo blk
blockInfo
            , ibiNestedCtxt :: SomeSecond (NestedCtxt Header) blk
ibiNestedCtxt   = SomeSecond (NestedCtxt Header) blk
nestedCtxt
            }

    -- | Insert the value at the key returning the updated map, unless there
    -- already is a key at the same location, in which case we return the
    -- original value.
    --
    -- Should be more efficient than the combination of 'Map.lookup' and
    -- 'Map.insert'.
    insertNew :: forall k a. Ord k => k -> a -> Map k a -> Either a (Map k a)
    insertNew :: k -> a -> Map k a -> Either a (Map k a)
insertNew k
k a
a Map k a
m =
      case (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)
forall k a.
Ord k =>
(k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)
Map.insertLookupWithKey (\k
_k a
new a
_old -> a
new) k
k a
a Map k a
m of
        (Maybe a
Nothing, Map k a
m') -> Map k a -> Either a (Map k a)
forall a b. b -> Either a b
Right Map k a
m'
        (Just a
a', Map k a
_)  -> a -> Either a (Map k a)
forall a b. a -> Either a b
Left a
a'