{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeApplications           #-}

module Ouroboros.Consensus.Storage.ImmutableDB.Impl.State (
    -- * State types
    ImmutableDBEnv (..)
  , InternalState (..)
  , OpenState (..)
  , dbIsOpen
    -- * State helpers
  , ModifyOpenState
  , cleanUp
  , closeOpenHandles
  , getOpenState
  , mkOpenState
  , modifyOpenState
  , withOpenState
  ) where

import           Control.Monad.State.Strict
import           Control.Tracer (Tracer)
import           Data.Typeable (Typeable)
import           GHC.Generics (Generic)
import           GHC.Stack (HasCallStack)

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Util (SomePair (..))
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.ResourceRegistry

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

import           Ouroboros.Consensus.Storage.ImmutableDB.API
import           Ouroboros.Consensus.Storage.ImmutableDB.Chunks
import           Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index (Index)
import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index as Index
import           Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Primary
                     (SecondaryOffset)
import           Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Secondary
                     (BlockOffset (..))
import           Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types
import           Ouroboros.Consensus.Storage.ImmutableDB.Impl.Util

{------------------------------------------------------------------------------
  Main types
------------------------------------------------------------------------------}

-- | The environment used by the immutable database.
data ImmutableDBEnv m blk = forall h. Eq h => ImmutableDBEnv {
      ()
hasFS            :: !(HasFS m h)
    , ()
varInternalState :: !(StrictMVar m (InternalState m blk h))
    , ImmutableDBEnv m blk -> blk -> Bool
checkIntegrity   :: !(blk -> Bool)
    , ImmutableDBEnv m blk -> ChunkInfo
chunkInfo        :: !ChunkInfo
    , ImmutableDBEnv m blk -> Tracer m (TraceEvent blk)
tracer           :: !(Tracer m (TraceEvent blk))
    , ImmutableDBEnv m blk -> CacheConfig
cacheConfig      :: !Index.CacheConfig
    , ImmutableDBEnv m blk -> CodecConfig blk
codecConfig      :: !(CodecConfig blk)
    }

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

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

-- | Internal state when the database is open.
data OpenState m blk h = OpenState {
      OpenState m blk h -> ChunkNo
currentChunk           :: !ChunkNo
      -- ^ The current 'ChunkNo' the immutable store is writing to.
    , OpenState m blk h -> BlockOffset
currentChunkOffset     :: !BlockOffset
      -- ^ The offset at which the next block will be written in the current
      -- chunk file.
    , OpenState m blk h -> SecondaryOffset
currentSecondaryOffset :: !SecondaryOffset
      -- ^ The offset at which the next index entry will be written in the
      -- current secondary index.
    , OpenState m blk h -> Handle h
currentChunkHandle     :: !(Handle h)
      -- ^ The write handle for the current chunk file.
    , OpenState m blk h -> Handle h
currentPrimaryHandle   :: !(Handle h)
      -- ^ The write handle for the current primary index file.
    , OpenState m blk h -> Handle h
currentSecondaryHandle :: !(Handle h)
      -- ^ The write handle for the current secondary index file.
    , OpenState m blk h -> WithOrigin (Tip blk)
currentTip             :: !(WithOrigin (Tip blk))
      -- ^ The current tip of the database.
    , OpenState m blk h -> Index m blk h
currentIndex           :: !(Index m blk h)
      -- ^ An abstraction layer on top of the indices to allow for caching.
    }
  deriving ((forall x. OpenState m blk h -> Rep (OpenState m blk h) x)
-> (forall x. Rep (OpenState m blk h) x -> OpenState m blk h)
-> Generic (OpenState m blk h)
forall x. Rep (OpenState m blk h) x -> OpenState m blk h
forall x. OpenState m blk h -> Rep (OpenState m blk h) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) blk h x.
Rep (OpenState m blk h) x -> OpenState m blk h
forall (m :: * -> *) blk h x.
OpenState m blk h -> Rep (OpenState m blk h) x
$cto :: forall (m :: * -> *) blk h x.
Rep (OpenState m blk h) x -> OpenState m blk h
$cfrom :: forall (m :: * -> *) blk h x.
OpenState m blk h -> Rep (OpenState m blk h) x
Generic, Context -> OpenState m blk h -> IO (Maybe ThunkInfo)
Proxy (OpenState m blk h) -> String
(Context -> OpenState m blk h -> IO (Maybe ThunkInfo))
-> (Context -> OpenState m blk h -> IO (Maybe ThunkInfo))
-> (Proxy (OpenState m blk h) -> String)
-> NoThunks (OpenState m blk h)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (m :: * -> *) blk h.
StandardHash blk =>
Context -> OpenState m blk h -> IO (Maybe ThunkInfo)
forall (m :: * -> *) blk h.
StandardHash blk =>
Proxy (OpenState m blk h) -> String
showTypeOf :: Proxy (OpenState m blk h) -> String
$cshowTypeOf :: forall (m :: * -> *) blk h.
StandardHash blk =>
Proxy (OpenState m blk h) -> String
wNoThunks :: Context -> OpenState m blk h -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *) blk h.
StandardHash blk =>
Context -> OpenState m blk h -> IO (Maybe ThunkInfo)
noThunks :: Context -> OpenState m blk h -> IO (Maybe ThunkInfo)
$cnoThunks :: forall (m :: * -> *) blk h.
StandardHash blk =>
Context -> OpenState m blk h -> IO (Maybe ThunkInfo)
NoThunks)

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

-- | Create the internal open state for the given chunk.
mkOpenState ::
     forall m blk h. (HasCallStack, IOLike m, Eq h)
  => HasFS m h
  -> Index m blk h
  -> ChunkNo
  -> WithOrigin (Tip blk)
  -> AllowExisting
  -> WithTempRegistry (OpenState m blk h) m (OpenState m blk h)
mkOpenState :: HasFS m h
-> Index m blk h
-> ChunkNo
-> WithOrigin (Tip blk)
-> AllowExisting
-> WithTempRegistry (OpenState m blk h) m (OpenState m blk h)
mkOpenState 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
hClose :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m ()
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
..} Index m blk h
index ChunkNo
chunk WithOrigin (Tip blk)
tip AllowExisting
existing = do
    Handle h
eHnd <- (OpenState m blk h -> Handle h)
-> m (Handle h)
-> WithTempRegistry (OpenState m blk h) m (Handle h)
allocateHandle OpenState m blk h -> Handle h
forall (m :: * -> *) blk h. OpenState m blk h -> Handle h
currentChunkHandle     (m (Handle h) -> WithTempRegistry (OpenState m blk h) m (Handle h))
-> m (Handle h)
-> WithTempRegistry (OpenState m blk h) m (Handle h)
forall a b. (a -> b) -> a -> b
$ HasCallStack => FsPath -> OpenMode -> m (Handle h)
FsPath -> OpenMode -> m (Handle h)
hOpen (ChunkNo -> FsPath
fsPathChunkFile          ChunkNo
chunk) OpenMode
appendMode
    Handle h
pHnd <- (OpenState m blk h -> Handle h)
-> m (Handle h)
-> WithTempRegistry (OpenState m blk h) m (Handle h)
allocateHandle OpenState m blk h -> Handle h
forall (m :: * -> *) blk h. OpenState m blk h -> Handle h
currentPrimaryHandle   (m (Handle h) -> WithTempRegistry (OpenState m blk h) m (Handle h))
-> m (Handle h)
-> WithTempRegistry (OpenState m blk h) m (Handle h)
forall a b. (a -> b) -> a -> b
$ Index m blk h -> ChunkNo -> AllowExisting -> m (Handle h)
forall (m :: * -> *) blk h.
Index m blk h
-> HasCallStack => ChunkNo -> AllowExisting -> m (Handle h)
Index.openPrimaryIndex Index m blk h
index    ChunkNo
chunk  AllowExisting
existing
    Handle h
sHnd <- (OpenState m blk h -> Handle h)
-> m (Handle h)
-> WithTempRegistry (OpenState m blk h) m (Handle h)
allocateHandle OpenState m blk h -> Handle h
forall (m :: * -> *) blk h. OpenState m blk h -> Handle h
currentSecondaryHandle (m (Handle h) -> WithTempRegistry (OpenState m blk h) m (Handle h))
-> m (Handle h)
-> WithTempRegistry (OpenState m blk h) m (Handle h)
forall a b. (a -> b) -> a -> b
$ HasCallStack => FsPath -> OpenMode -> m (Handle h)
FsPath -> OpenMode -> m (Handle h)
hOpen (ChunkNo -> FsPath
fsPathSecondaryIndexFile ChunkNo
chunk) OpenMode
appendMode
    Word64
chunkOffset     <- m Word64 -> WithTempRegistry (OpenState m blk h) m Word64
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Word64 -> WithTempRegistry (OpenState m blk h) m Word64)
-> m Word64 -> WithTempRegistry (OpenState m blk h) m Word64
forall a b. (a -> b) -> a -> b
$ HasCallStack => Handle h -> m Word64
Handle h -> m Word64
hGetSize Handle h
eHnd
    Word64
secondaryOffset <- m Word64 -> WithTempRegistry (OpenState m blk h) m Word64
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Word64 -> WithTempRegistry (OpenState m blk h) m Word64)
-> m Word64 -> WithTempRegistry (OpenState m blk h) m Word64
forall a b. (a -> b) -> a -> b
$ HasCallStack => Handle h -> m Word64
Handle h -> m Word64
hGetSize Handle h
sHnd
    OpenState m blk h
-> WithTempRegistry (OpenState m blk h) m (OpenState m blk h)
forall (m :: * -> *) a. Monad m => a -> m a
return OpenState :: forall (m :: * -> *) blk h.
ChunkNo
-> BlockOffset
-> SecondaryOffset
-> Handle h
-> Handle h
-> Handle h
-> WithOrigin (Tip blk)
-> Index m blk h
-> OpenState m blk h
OpenState
      { currentChunk :: ChunkNo
currentChunk           = ChunkNo
chunk
      , currentChunkOffset :: BlockOffset
currentChunkOffset     = Word64 -> BlockOffset
BlockOffset Word64
chunkOffset
      , currentSecondaryOffset :: SecondaryOffset
currentSecondaryOffset = Word64 -> SecondaryOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
secondaryOffset
      , currentChunkHandle :: Handle h
currentChunkHandle     = Handle h
eHnd
      , currentPrimaryHandle :: Handle h
currentPrimaryHandle   = Handle h
pHnd
      , currentSecondaryHandle :: Handle h
currentSecondaryHandle = Handle h
sHnd
      , currentTip :: WithOrigin (Tip blk)
currentTip             = WithOrigin (Tip blk)
tip
      , currentIndex :: Index m blk h
currentIndex           = Index m blk h
index
      }
  where
    appendMode :: OpenMode
appendMode = AllowExisting -> OpenMode
AppendMode AllowExisting
existing

    allocateHandle
      :: (OpenState m blk h -> Handle h)
      -> m (Handle h)
      -> WithTempRegistry (OpenState m blk h) m (Handle h)
    allocateHandle :: (OpenState m blk h -> Handle h)
-> m (Handle h)
-> WithTempRegistry (OpenState m blk h) m (Handle h)
allocateHandle OpenState m blk h -> Handle h
getHandle m (Handle h)
open =
      -- To check whether the handle made it in the final state, we check for
      -- equality.
      m (Handle h)
-> (Handle h -> m Bool)
-> (OpenState m blk h -> Handle h -> Bool)
-> WithTempRegistry (OpenState m 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 m (Handle h)
open (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 m blk h -> Handle h)
-> OpenState m blk h
-> Handle h
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OpenState m blk h -> Handle h
getHandle)

-- | Get the 'OpenState' of the given database, throw a 'ClosedDBError' in
-- case it is closed.
--
-- NOTE: Since the 'OpenState' is parameterized over a type parameter @h@ of
-- handles, which is not visible from the type of the @ImmutableDBEnv@,
-- we return a @SomePair@ here that returns the open state along with a 'HasFS'
-- instance for the /same/ type parameter @h@. Note that it would be impossible
-- to use an existing 'HasFS' instance already in scope otherwise, since the
-- @h@ parameters would not be known to match.
getOpenState ::
     forall m blk. (HasCallStack, IOLike m, StandardHash blk, Typeable blk)
  => ImmutableDBEnv m blk
  -> STM m (SomePair (HasFS m) (OpenState m blk))
getOpenState :: ImmutableDBEnv m blk
-> STM m (SomePair (HasFS m) (OpenState m blk))
getOpenState ImmutableDBEnv {Tracer m (TraceEvent blk)
HasFS m h
CodecConfig blk
StrictMVar m (InternalState m blk h)
ChunkInfo
CacheConfig
blk -> Bool
codecConfig :: CodecConfig blk
cacheConfig :: CacheConfig
tracer :: Tracer m (TraceEvent blk)
chunkInfo :: ChunkInfo
checkIntegrity :: blk -> Bool
varInternalState :: StrictMVar m (InternalState m blk h)
hasFS :: HasFS m h
codecConfig :: forall (m :: * -> *) blk. ImmutableDBEnv m blk -> CodecConfig blk
cacheConfig :: forall (m :: * -> *) blk. ImmutableDBEnv m blk -> CacheConfig
tracer :: forall (m :: * -> *) blk.
ImmutableDBEnv m blk -> Tracer m (TraceEvent blk)
chunkInfo :: forall (m :: * -> *) blk. ImmutableDBEnv m blk -> ChunkInfo
checkIntegrity :: forall (m :: * -> *) blk. ImmutableDBEnv m blk -> blk -> Bool
varInternalState :: ()
hasFS :: ()
..} = do
    -- We use 'readMVarSTM' to read a potentially stale internal state if
    -- somebody's appending to the ImmutableDB at the same time.
    InternalState m blk h
internalState <- StrictMVar m (InternalState m blk h)
-> STM m (InternalState m blk h)
forall (m :: * -> *) a. MonadSTM m => StrictMVar m a -> STM m a
readMVarSTM StrictMVar m (InternalState m blk h)
varInternalState
    case InternalState m blk h
internalState of
       InternalState m blk h
DbClosed         -> ApiMisuse blk -> STM m (SomePair (HasFS m) (OpenState m blk))
forall (m :: * -> *) blk a.
(MonadThrow m, HasCallStack, StandardHash blk, Typeable blk) =>
ApiMisuse blk -> m a
throwApiMisuse (ApiMisuse blk -> STM m (SomePair (HasFS m) (OpenState m blk)))
-> ApiMisuse blk -> STM m (SomePair (HasFS m) (OpenState m blk))
forall a b. (a -> b) -> a -> b
$ ApiMisuse blk
forall blk. ApiMisuse blk
ClosedDBError @blk
       DbOpen OpenState m blk h
openState -> SomePair (HasFS m) (OpenState m blk)
-> STM m (SomePair (HasFS m) (OpenState m blk))
forall (m :: * -> *) a. Monad m => a -> m a
return (HasFS m h
-> OpenState m blk h -> SomePair (HasFS m) (OpenState m blk)
forall k (f :: k -> *) (a :: k) (g :: k -> *).
f a -> g a -> SomePair f g
SomePair HasFS m h
hasFS OpenState m blk h
openState)

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

-- | Modify the internal state of an open database.
--
-- In case the database is closed, a 'ClosedDBError' is thrown.
--
-- In case an 'UnexpectedFailure' is thrown, the database is closed to prevent
-- further appending to a database in a potentially inconsistent state.
--
-- The action is run in the 'ModifyOpenState' monad, which is a 'StateT'
-- transformer (of the 'OpenState') over the 'WithTempRegistry' monad. This
-- monad can be used to allocate resources in that will be transferred to the
-- returned 'OpenState' that is safely stored in the 'ImmutableDBEnv'. This
-- approach makes sure that no resources are leaked when an exception is
-- thrown while running the action modifying the state.
--
-- __Note__: This /takes/ the 'TMVar', /then/ runs the action (which might be
-- in 'IO'), and then puts the 'TMVar' back, just like
-- 'Control.Concurrent.MVar.modifyMVar' does. Consequently, it has the same
-- gotchas that @modifyMVar@ does; the effects are observable and it is
-- susceptible to deadlock.
modifyOpenState ::
     forall m blk a. (HasCallStack, IOLike m, StandardHash blk, Typeable blk)
  => ImmutableDBEnv m blk
  -> (forall h. Eq h => HasFS m h -> ModifyOpenState m blk h a)
  -> m a
modifyOpenState :: ImmutableDBEnv m blk
-> (forall h. Eq h => HasFS m h -> ModifyOpenState m blk h a)
-> m a
modifyOpenState ImmutableDBEnv { hasFS :: ()
hasFS = HasFS m h
hasFS :: HasFS m h, Tracer m (TraceEvent blk)
CodecConfig blk
StrictMVar m (InternalState m blk h)
ChunkInfo
CacheConfig
blk -> Bool
codecConfig :: CodecConfig blk
cacheConfig :: CacheConfig
tracer :: Tracer m (TraceEvent blk)
chunkInfo :: ChunkInfo
checkIntegrity :: blk -> Bool
varInternalState :: StrictMVar m (InternalState m blk h)
codecConfig :: forall (m :: * -> *) blk. ImmutableDBEnv m blk -> CodecConfig blk
cacheConfig :: forall (m :: * -> *) blk. ImmutableDBEnv m blk -> CacheConfig
tracer :: forall (m :: * -> *) blk.
ImmutableDBEnv m blk -> Tracer m (TraceEvent blk)
chunkInfo :: forall (m :: * -> *) blk. ImmutableDBEnv m blk -> ChunkInfo
checkIntegrity :: forall (m :: * -> *) blk. ImmutableDBEnv m blk -> blk -> Bool
varInternalState :: ()
.. } forall h. Eq h => HasFS m h -> ModifyOpenState m blk h a
modSt =
    Proxy blk -> m a -> m a
forall blk (m :: * -> *) a.
(MonadCatch m, StandardHash blk, Typeable blk) =>
Proxy blk -> m a -> m a
wrapFsError (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk) (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ m (OpenState m blk h)
-> (OpenState m blk h -> ExitCase (OpenState m blk h) -> m ())
-> StateT
     (OpenState m blk h) (WithTempRegistry (OpenState m 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 m blk h)
getSt OpenState m blk h -> ExitCase (OpenState m blk h) -> m ()
putSt (HasFS m h
-> StateT
     (OpenState m blk h) (WithTempRegistry (OpenState m blk h) m) a
forall h. Eq h => HasFS m h -> ModifyOpenState m blk h a
modSt HasFS m h
hasFS)
  where
    getSt :: m (OpenState m blk h)
    getSt :: m (OpenState m blk h)
getSt = m (OpenState m blk h) -> m (OpenState m blk h)
forall (m :: * -> *) a. MonadMask m => m a -> m a
mask_ (m (OpenState m blk h) -> m (OpenState m blk h))
-> m (OpenState m blk h) -> m (OpenState m blk h)
forall a b. (a -> b) -> a -> b
$ StrictMVar m (InternalState m blk h) -> m (InternalState m blk h)
forall (m :: * -> *) a. MonadSTM m => StrictMVar m a -> m a
takeMVar StrictMVar m (InternalState m blk h)
varInternalState m (InternalState m blk h)
-> (InternalState m blk h -> m (OpenState m blk h))
-> m (OpenState m blk h)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      DbOpen OpenState m blk h
ost -> OpenState m blk h -> m (OpenState m blk h)
forall (m :: * -> *) a. Monad m => a -> m a
return OpenState m blk h
ost
      InternalState m blk h
DbClosed   -> do
        StrictMVar m (InternalState m blk h)
-> InternalState m blk h -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictMVar m a -> a -> m ()
putMVar StrictMVar m (InternalState m blk h)
varInternalState InternalState m blk h
forall (m :: * -> *) blk h. InternalState m blk h
DbClosed
        ApiMisuse blk -> m (OpenState m blk h)
forall (m :: * -> *) blk a.
(MonadThrow m, HasCallStack, StandardHash blk, Typeable blk) =>
ApiMisuse blk -> m a
throwApiMisuse (ApiMisuse blk -> m (OpenState m blk h))
-> ApiMisuse blk -> m (OpenState m blk h)
forall a b. (a -> b) -> a -> b
$ ApiMisuse blk
forall blk. ApiMisuse blk
ClosedDBError @blk

    putSt :: OpenState m blk h -> ExitCase (OpenState m blk h) -> m ()
    putSt :: OpenState m blk h -> ExitCase (OpenState m blk h) -> m ()
putSt OpenState m blk h
ost ExitCase (OpenState m blk h)
ec = do
        -- It is crucial to replace the MVar.
        StrictMVar m (InternalState m blk h)
-> InternalState m blk h -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictMVar m a -> a -> m ()
putMVar StrictMVar m (InternalState m blk h)
varInternalState InternalState m blk h
st'
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (InternalState m blk h -> Bool
forall (m :: * -> *) blk h. InternalState m blk h -> Bool
dbIsOpen InternalState m blk h
st') (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ HasFS m h -> OpenState m blk h -> m ()
forall (m :: * -> *) h blk.
Monad m =>
HasFS m h -> OpenState m blk h -> m ()
cleanUp HasFS m h
hasFS OpenState m blk h
ost
      where
        st' :: InternalState m blk h
st' = case ExitCase (OpenState m blk h)
ec of
          ExitCaseSuccess OpenState m blk h
ost'  -> OpenState m blk h -> InternalState m blk h
forall (m :: * -> *) blk h.
OpenState m blk h -> InternalState m blk h
DbOpen OpenState m blk h
ost'

          -- When something goes wrong, close the ImmutableDB for safety.
          -- Except for user errors, because they stem from incorrect use of
          -- the ImmutableDB.
          --
          -- NOTE: we only modify the ImmutableDB in a background thread of
          -- the ChainDB, not in per-connection threads that could be killed
          -- at any point. When an exception is encountered while modifying
          -- the ImmutableDB in the 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 ImmutableDB here.
          ExitCase (OpenState m blk h)
ExitCaseAbort         -> InternalState m blk h
forall (m :: * -> *) blk h. InternalState m blk h
DbClosed
          ExitCaseException SomeException
ex
            | Just (ApiMisuse {} :: ImmutableDBError blk) <- SomeException -> Maybe (ImmutableDBError blk)
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex
            -> OpenState m blk h -> InternalState m blk h
forall (m :: * -> *) blk h.
OpenState m blk h -> InternalState m blk h
DbOpen OpenState m blk h
ost
            | Bool
otherwise
            -> InternalState m blk h
forall (m :: * -> *) blk h. InternalState m blk h
DbClosed

-- | 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.
withOpenState ::
     forall m blk r. (HasCallStack, IOLike m, StandardHash blk, Typeable blk)
  => ImmutableDBEnv m blk
  -> (forall h. HasFS m h -> OpenState m blk h -> m r)
  -> m r
withOpenState :: ImmutableDBEnv m blk
-> (forall h. HasFS m h -> OpenState m blk h -> m r) -> m r
withOpenState ImmutableDBEnv { hasFS :: ()
hasFS = HasFS m h
hasFS :: HasFS m h, Tracer m (TraceEvent blk)
CodecConfig blk
StrictMVar m (InternalState m blk h)
ChunkInfo
CacheConfig
blk -> Bool
codecConfig :: CodecConfig blk
cacheConfig :: CacheConfig
tracer :: Tracer m (TraceEvent blk)
chunkInfo :: ChunkInfo
checkIntegrity :: blk -> Bool
varInternalState :: StrictMVar m (InternalState m blk h)
codecConfig :: forall (m :: * -> *) blk. ImmutableDBEnv m blk -> CodecConfig blk
cacheConfig :: forall (m :: * -> *) blk. ImmutableDBEnv m blk -> CacheConfig
tracer :: forall (m :: * -> *) blk.
ImmutableDBEnv m blk -> Tracer m (TraceEvent blk)
chunkInfo :: forall (m :: * -> *) blk. ImmutableDBEnv m blk -> ChunkInfo
checkIntegrity :: forall (m :: * -> *) blk. ImmutableDBEnv m blk -> blk -> Bool
varInternalState :: ()
.. } forall h. HasFS m h -> OpenState m blk h -> m r
action = do
    (Either (ImmutableDBError blk) r
mr, ()) <-
      m (OpenState m blk h)
-> (OpenState m blk h
    -> ExitCase (Either (ImmutableDBError blk) r) -> m ())
-> (OpenState m blk h -> m (Either (ImmutableDBError blk) r))
-> m (Either (ImmutableDBError 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 m blk h)
open ((ExitCase (Either (ImmutableDBError blk) r) -> m ())
-> OpenState m blk h
-> ExitCase (Either (ImmutableDBError blk) r)
-> m ()
forall a b. a -> b -> a
const ExitCase (Either (ImmutableDBError blk) r) -> m ()
close) (Proxy blk -> m r -> m (Either (ImmutableDBError blk) r)
forall (m :: * -> *) blk a.
(MonadCatch m, StandardHash blk, Typeable blk) =>
Proxy blk -> m a -> m (Either (ImmutableDBError blk) a)
tryImmutableDB (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk) (m r -> m (Either (ImmutableDBError blk) r))
-> (OpenState m blk h -> m r)
-> OpenState m blk h
-> m (Either (ImmutableDBError blk) r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OpenState m blk h -> m r
access)
    case Either (ImmutableDBError blk) r
mr of
      Left  ImmutableDBError blk
e -> ImmutableDBError blk -> m r
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO ImmutableDBError blk
e
      Right r
r -> r -> m r
forall (m :: * -> *) a. Monad m => a -> m a
return r
r
  where
    -- We use 'readMVarSTM' to read a potentially stale internal state if
    -- somebody's appending to the ImmutableDB at the same time. Reads can
    -- safely happen concurrently with appends, so this is fine and allows for
    -- some extra concurrency.
    open :: m (OpenState m blk h)
    open :: m (OpenState m blk h)
open = STM m (InternalState m blk h) -> m (InternalState m blk h)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictMVar m (InternalState m blk h)
-> STM m (InternalState m blk h)
forall (m :: * -> *) a. MonadSTM m => StrictMVar m a -> STM m a
readMVarSTM StrictMVar m (InternalState m blk h)
varInternalState) m (InternalState m blk h)
-> (InternalState m blk h -> m (OpenState m blk h))
-> m (OpenState m blk h)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      DbOpen OpenState m blk h
ost -> OpenState m blk h -> m (OpenState m blk h)
forall (m :: * -> *) a. Monad m => a -> m a
return OpenState m blk h
ost
      InternalState m blk h
DbClosed   -> ApiMisuse blk -> m (OpenState m blk h)
forall (m :: * -> *) blk a.
(MonadThrow m, HasCallStack, StandardHash blk, Typeable blk) =>
ApiMisuse blk -> m a
throwApiMisuse (ApiMisuse blk -> m (OpenState m blk h))
-> ApiMisuse blk -> m (OpenState m blk h)
forall a b. (a -> b) -> a -> b
$ ApiMisuse blk
forall blk. ApiMisuse blk
ClosedDBError @blk

    -- close doesn't take the state that @open@ returned, because the state
    -- may have been updated by someone else since we got it (remember we're
    -- using 'readMVarSTM' here, not 'takeMVar'). So we need to get the most
    -- recent state anyway.
    close :: ExitCase (Either (ImmutableDBError blk) r)
          -> m ()
    close :: ExitCase (Either (ImmutableDBError blk) r) -> m ()
close ExitCase (Either (ImmutableDBError blk) r)
ec = case ExitCase (Either (ImmutableDBError blk) r)
ec of
      ExitCase (Either (ImmutableDBError blk) r)
ExitCaseAbort                                 -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      ExitCaseException SomeException
_ex                         -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      ExitCaseSuccess (Right r
_)                     -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      -- In case of an ImmutableDBError, close when unexpected
      ExitCaseSuccess (Left (UnexpectedFailure {})) -> m ()
shutDown
      ExitCaseSuccess (Left (ApiMisuse {}))         -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    shutDown :: m ()
    shutDown :: m ()
shutDown = StrictMVar m (InternalState m blk h)
-> InternalState m blk h -> m (InternalState m blk h)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictMVar m a -> a -> m a
swapMVar StrictMVar m (InternalState m blk h)
varInternalState InternalState m blk h
forall (m :: * -> *) blk h. InternalState m blk h
DbClosed m (InternalState m blk h)
-> (InternalState m blk h -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      DbOpen OpenState m blk h
ost -> Proxy blk -> m () -> m ()
forall blk (m :: * -> *) a.
(MonadCatch m, StandardHash blk, Typeable blk) =>
Proxy blk -> m a -> m a
wrapFsError (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ HasFS m h -> OpenState m blk h -> m ()
forall (m :: * -> *) h blk.
Monad m =>
HasFS m h -> OpenState m blk h -> m ()
cleanUp HasFS m h
hasFS OpenState m blk h
ost
      InternalState m blk h
DbClosed   -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

-- | Close the handles in the 'OpenState'.
--
-- Idempotent, as closing a handle is idempotent.
closeOpenHandles :: Monad m => HasFS m h -> OpenState m blk h -> m ()
closeOpenHandles :: HasFS m h -> OpenState m 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 {SecondaryOffset
WithOrigin (Tip blk)
Handle h
ChunkNo
BlockOffset
Index m blk h
currentIndex :: Index m blk h
currentTip :: WithOrigin (Tip blk)
currentSecondaryHandle :: Handle h
currentPrimaryHandle :: Handle h
currentChunkHandle :: Handle h
currentSecondaryOffset :: SecondaryOffset
currentChunkOffset :: BlockOffset
currentChunk :: ChunkNo
currentIndex :: forall (m :: * -> *) blk h. OpenState m blk h -> Index m blk h
currentTip :: forall (m :: * -> *) blk h.
OpenState m blk h -> WithOrigin (Tip blk)
currentSecondaryHandle :: forall (m :: * -> *) blk h. OpenState m blk h -> Handle h
currentPrimaryHandle :: forall (m :: * -> *) blk h. OpenState m blk h -> Handle h
currentChunkHandle :: forall (m :: * -> *) blk h. OpenState m blk h -> Handle h
currentSecondaryOffset :: forall (m :: * -> *) blk h. OpenState m blk h -> SecondaryOffset
currentChunkOffset :: forall (m :: * -> *) blk h. OpenState m blk h -> BlockOffset
currentChunk :: forall (m :: * -> *) blk h. OpenState m blk h -> ChunkNo
..}  = do
    HasCallStack => Handle h -> m ()
Handle h -> m ()
hClose Handle h
currentChunkHandle
    HasCallStack => Handle h -> m ()
Handle h -> m ()
hClose Handle h
currentPrimaryHandle
    HasCallStack => Handle h -> m ()
Handle h -> m ()
hClose Handle h
currentSecondaryHandle

-- | Clean up the 'OpenState': 'closeOpenHandles' + close the index (i.e.,
-- shut down its background thread)
cleanUp :: Monad m => HasFS m h -> OpenState m blk h -> m ()
cleanUp :: HasFS m h -> OpenState m blk h -> m ()
cleanUp HasFS m h
hasFS ost :: OpenState m blk h
ost@OpenState {SecondaryOffset
WithOrigin (Tip blk)
Handle h
ChunkNo
BlockOffset
Index m blk h
currentIndex :: Index m blk h
currentTip :: WithOrigin (Tip blk)
currentSecondaryHandle :: Handle h
currentPrimaryHandle :: Handle h
currentChunkHandle :: Handle h
currentSecondaryOffset :: SecondaryOffset
currentChunkOffset :: BlockOffset
currentChunk :: ChunkNo
currentIndex :: forall (m :: * -> *) blk h. OpenState m blk h -> Index m blk h
currentTip :: forall (m :: * -> *) blk h.
OpenState m blk h -> WithOrigin (Tip blk)
currentSecondaryHandle :: forall (m :: * -> *) blk h. OpenState m blk h -> Handle h
currentPrimaryHandle :: forall (m :: * -> *) blk h. OpenState m blk h -> Handle h
currentChunkHandle :: forall (m :: * -> *) blk h. OpenState m blk h -> Handle h
currentSecondaryOffset :: forall (m :: * -> *) blk h. OpenState m blk h -> SecondaryOffset
currentChunkOffset :: forall (m :: * -> *) blk h. OpenState m blk h -> BlockOffset
currentChunk :: forall (m :: * -> *) blk h. OpenState m blk h -> ChunkNo
..}  = do
    Index m blk h -> HasCallStack => m ()
forall (m :: * -> *) blk h. Index m blk h -> HasCallStack => m ()
Index.close Index m blk h
currentIndex
    HasFS m h -> OpenState m blk h -> m ()
forall (m :: * -> *) h blk.
Monad m =>
HasFS m h -> OpenState m blk h -> m ()
closeOpenHandles HasFS m h
hasFS OpenState m blk h
ost