{-# 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 (
TraceEvent (..)
, BlockOffset (..)
, BlockSize (..)
, FileId
, InternalState (..)
, OpenState (..)
, ReverseIndex
, SuccessorsIndex
, VolatileDBEnv (..)
, dbIsOpen
, 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 as 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.Consensus.Block
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
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.Network.Block (MaxSlotNo (..))
import System.FS.API
data VolatileDBEnv m blk = forall h. Eq h => VolatileDBEnv {
()
hasFS :: !(HasFS m h)
, ()
varInternalState :: !(RAWLock m (InternalState blk h))
, forall (m :: * -> *) blk. VolatileDBEnv m blk -> BlocksPerFile
maxBlocksPerFile :: !BlocksPerFile
, forall (m :: * -> *) blk. VolatileDBEnv m blk -> blk -> Bool
checkIntegrity :: !(blk -> Bool)
, forall (m :: * -> *) blk. VolatileDBEnv m blk -> CodecConfig blk
codecConfig :: !(CodecConfig blk)
, forall (m :: * -> *) 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
$cfrom :: forall blk h x. InternalState blk h -> Rep (InternalState blk h) x
from :: forall x. InternalState blk h -> Rep (InternalState blk h) x
$cto :: forall blk h x. Rep (InternalState blk h) x -> InternalState blk h
to :: forall x. Rep (InternalState blk h) x -> InternalState blk h
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
$cnoThunks :: forall blk h.
(StandardHash blk, Typeable blk) =>
Context -> InternalState blk h -> IO (Maybe ThunkInfo)
noThunks :: Context -> InternalState blk h -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk h.
(StandardHash blk, Typeable blk) =>
Context -> InternalState blk h -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> InternalState blk h -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall blk h.
(StandardHash blk, Typeable blk) =>
Proxy (InternalState blk h) -> String
showTypeOf :: Proxy (InternalState blk h) -> String
NoThunks)
dbIsOpen :: InternalState blk h -> Bool
dbIsOpen :: forall blk h. InternalState blk h -> Bool
dbIsOpen (DbOpen OpenState blk h
_) = Bool
True
dbIsOpen InternalState blk h
DbClosed = Bool
False
data OpenState blk h = OpenState {
forall blk h. OpenState blk h -> Handle h
currentWriteHandle :: !(Handle h)
, forall blk h. OpenState blk h -> FsPath
currentWritePath :: !FsPath
, forall blk h. OpenState blk h -> FileId
currentWriteId :: !FileId
, forall blk h. OpenState blk h -> Word64
currentWriteOffset :: !Word64
, forall blk h. OpenState blk h -> Index blk
currentMap :: !(Index blk)
, forall blk h. OpenState blk h -> ReverseIndex blk
currentRevMap :: !(ReverseIndex blk)
, forall blk h. OpenState blk h -> SuccessorsIndex blk
currentSuccMap :: !(SuccessorsIndex blk)
, forall blk h. OpenState blk h -> MaxSlotNo
currentMaxSlotNo :: !MaxSlotNo
}
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
$cfrom :: forall blk h x. OpenState blk h -> Rep (OpenState blk h) x
from :: forall x. OpenState blk h -> Rep (OpenState blk h) x
$cto :: forall blk h x. Rep (OpenState blk h) x -> OpenState blk h
to :: forall x. Rep (OpenState blk h) x -> OpenState blk h
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
$cnoThunks :: forall blk h.
(StandardHash blk, Typeable blk) =>
Context -> OpenState blk h -> IO (Maybe ThunkInfo)
noThunks :: Context -> OpenState blk h -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk h.
(StandardHash blk, Typeable blk) =>
Context -> OpenState blk h -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> OpenState blk h -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall blk h.
(StandardHash blk, Typeable blk) =>
Proxy (OpenState blk h) -> String
showTypeOf :: Proxy (OpenState blk h) -> String
NoThunks)
type ModifyOpenState m blk h =
StateT (OpenState blk h) (WithTempRegistry (OpenState blk h) m)
data AppendOrWrite = Append | Write
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 :: 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
appendOrWrite
VolatileDBEnv {hasFS :: ()
hasFS = HasFS m h
hasFS :: HasFS m h, RAWLock m (InternalState blk h)
varInternalState :: ()
varInternalState :: RAWLock m (InternalState blk h)
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 (forall t. Proxy t
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
(RAWLock m a -> m a
acquire, RAWLock m x1 -> x1 -> m ()
release) = case AppendOrWrite
appendOrWrite of
AppendOrWrite
Append ->
(STM m a -> m a
forall a. HasCallStack => 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 a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ())
-> (RAWLock m x1 -> x1 -> STM m ()) -> RAWLock m x1 -> x1 -> m ()
forall y z x0 x1. (y -> z) -> (x0 -> x1 -> y) -> x0 -> x1 -> z
.: RAWLock m x1 -> x1 -> 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 x1 -> x1 -> 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 a b. m a -> (a -> m b) -> m b
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 a. a -> m a
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 {x1}. RAWLock m x1 -> x1 -> 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 e a. Exception e => e -> m a
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
$ 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
Left SomeException
ex -> do
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 ->
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 {x1}. RAWLock m x1 -> x1 -> 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'
ExitCase (OpenState blk h)
ExitCaseAbort
-> 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
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 :: 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 = 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
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 :: 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 = 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
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 :: 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 {hasFS :: ()
hasFS = HasFS m h
hasFS :: HasFS m h, RAWLock m (InternalState blk h)
varInternalState :: ()
varInternalState :: RAWLock m (InternalState blk h)
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 a b c.
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
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 (forall t. Proxy t
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 e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO VolatileDBError blk
e
Right r
r -> r -> m r
forall a. a -> m a
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 a. HasCallStack => STM m a -> m a
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 a b. m a -> (a -> m b) -> m b
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return OpenState blk h
ost
InternalState blk h
DbClosed -> do
STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
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 e a. Exception e => e -> m a
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
$ 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
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 ->
forall blk. ApiMisuse -> VolatileDBError blk
ApiMisuse @blk (Maybe SomeException -> ApiMisuse
ClosedDBError (SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
ex))
Proxy blk -> m () -> m ()
forall (m :: * -> *) a blk.
(MonadCatch m, StandardHash blk, Typeable blk) =>
Proxy blk -> m a -> m a
wrapFsError (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ case Maybe (InternalState blk h)
mbCurState of
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'
Just InternalState blk h
DbClosed -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
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 a. HasCallStack => STM m a -> m a
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
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
closeOpenHandles :: HasFS m h -> OpenState blk h -> m ()
closeOpenHandles :: forall (m :: * -> *) h blk. HasFS m h -> OpenState blk h -> m ()
closeOpenHandles HasFS { HasCallStack => Handle h -> m ()
hClose :: HasCallStack => Handle h -> m ()
hClose :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m ()
hClose } OpenState { Handle h
currentWriteHandle :: forall blk h. OpenState blk h -> Handle h
currentWriteHandle :: 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 :: 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 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 =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
HasCallStack => FsPath -> m Bool
HasCallStack => FsPath -> m ()
HasCallStack => FsPath -> m (Set String)
HasCallStack => FsPath -> FsPath -> m ()
HasCallStack => FsPath -> OpenMode -> m (Handle h)
FsPath -> m String
FsPath -> FsErrorPath
hClose :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m ()
dumpState :: m String
hOpen :: HasCallStack => FsPath -> OpenMode -> m (Handle h)
hClose :: HasCallStack => Handle h -> m ()
hIsOpen :: HasCallStack => Handle h -> m Bool
hSeek :: HasCallStack => Handle h -> SeekMode -> Int64 -> m ()
hGetSome :: HasCallStack => Handle h -> Word64 -> m ByteString
hGetSomeAt :: HasCallStack => Handle h -> Word64 -> AbsOffset -> m ByteString
hPutSome :: HasCallStack => Handle h -> ByteString -> m Word64
hTruncate :: HasCallStack => Handle h -> Word64 -> m ()
hGetSize :: HasCallStack => Handle h -> m Word64
createDirectory :: HasCallStack => FsPath -> m ()
createDirectoryIfMissing :: HasCallStack => Bool -> FsPath -> m ()
listDirectory :: HasCallStack => FsPath -> m (Set String)
doesDirectoryExist :: HasCallStack => FsPath -> m Bool
doesFileExist :: HasCallStack => FsPath -> m Bool
removeDirectoryRecursive :: HasCallStack => FsPath -> m ()
removeFile :: HasCallStack => FsPath -> m ()
renameFile :: HasCallStack => FsPath -> FsPath -> m ()
mkFsErrorPath :: FsPath -> FsErrorPath
unsafeToFilePath :: FsPath -> m String
hGetBufSome :: HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
hGetBufSomeAt :: HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
hPutBufSome :: HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
hPutBufSomeAt :: HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
dumpState :: forall (m :: * -> *) h. HasFS m h -> m String
hOpen :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> OpenMode -> m (Handle h)
hIsOpen :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m Bool
hSeek :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> SeekMode -> Int64 -> m ()
hGetSome :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> Word64 -> m ByteString
hGetSomeAt :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack => Handle h -> Word64 -> AbsOffset -> m ByteString
hPutSome :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> ByteString -> m Word64
hTruncate :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> Word64 -> m ()
hGetSize :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m Word64
createDirectory :: forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
createDirectoryIfMissing :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Bool -> FsPath -> m ()
listDirectory :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m (Set String)
doesDirectoryExist :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesFileExist :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
removeDirectoryRecursive :: forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
removeFile :: forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
renameFile :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> FsPath -> m ()
mkFsErrorPath :: forall (m :: * -> *) h. HasFS m h -> FsPath -> FsErrorPath
unsafeToFilePath :: forall (m :: * -> *) h. HasFS m h -> FsPath -> m String
hGetBufSome :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
hGetBufSomeAt :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
hPutBufSome :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
hPutBufSomeAt :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
..} blk -> Bool
checkInvariants BlockValidationPolicy
validationPolicy Tracer m (TraceEvent blk)
tracer BlocksPerFile
maxBlocksPerFile = do
m () -> WithTempRegistry (OpenState blk h) m ()
forall (m :: * -> *) a.
Monad m =>
m a -> WithTempRegistry (OpenState blk h) m a
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 (m :: * -> *) a.
Monad m =>
m a -> WithTempRegistry (OpenState blk h) m a
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 (m :: * -> *) a.
Monad m =>
m a -> WithTempRegistry (OpenState blk h) m a
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, 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
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 a. [a] -> 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 a. a -> m a
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]
type Indices blk =
( Index blk
, ReverseIndex blk
, SuccessorsIndex blk
)
mkOpenStateHelper ::
forall blk m 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
-> [(FileId, FsPath)]
-> WithTempRegistry (OpenState blk h) m (OpenState blk h)
mkOpenStateHelper :: forall blk (m :: * -> *) 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
-> [(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 (m :: * -> *) a.
Monad m =>
m a -> WithTempRegistry (OpenState blk h) m a
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
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
-> (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
-> (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 -> HasCallStack => 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 (m :: * -> *) a.
Monad m =>
m a -> WithTempRegistry (OpenState blk h) m a
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 -> HasCallStack => 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 a. a -> WithTempRegistry (OpenState blk h) m a
forall (m :: * -> *) a. Monad m => a -> m a
return 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
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 b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl'
(\Map (ChainHash blk) (Set (HeaderHash blk))
succMap ParsedBlockInfo { BlockInfo blk
pbiBlockInfo :: BlockInfo blk
pbiBlockInfo :: forall blk. ParsedBlockInfo blk -> 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 a. a -> m a
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
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 -> HasCallStack => 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)
addToReverseIndex ::
forall blk. HasHeader blk
=> FsPath
-> ReverseIndex blk
-> [ParsedBlockInfo blk]
-> ( ReverseIndex blk
, [ParsedBlockInfo blk]
, Maybe (ParseError blk, BlockOffset)
)
addToReverseIndex :: forall blk.
HasHeader blk =>
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]
-> [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 :: forall blk. BlockInfo blk -> HeaderHash blk
biHash :: 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 {
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
}
insertNew :: forall k a. Ord k => k -> a -> Map k a -> Either a (Map k a)
insertNew :: forall k a. Ord k => 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'