{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

module Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index
  ( -- * Index
    Index (..)
  , readEntry
  , readOffset

    -- * File-backed index
  , fileBackedIndex

    -- * Cached index
  , CacheConfig (..)
  , cachedIndex
  ) where

import Control.ResourceRegistry
import Control.Tracer (Tracer)
import Data.Functor.Identity (Identity (..))
import Data.Proxy (Proxy (..))
import Data.Sequence.Strict (StrictSeq)
import Data.Typeable (Typeable)
import Data.Word (Word64)
import GHC.Stack (HasCallStack)
import NoThunks.Class (OnlyCheckWhnfNamed (..))
import Ouroboros.Consensus.Block (ConvertRawHash, IsEBB, StandardHash)
import Ouroboros.Consensus.Storage.ImmutableDB.Chunks
import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Cache
  ( CacheConfig (..)
  )
import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Cache as Cache
import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Primary
  ( SecondaryOffset
  )
import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Primary as Primary
import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Secondary
  ( BlockSize
  )
import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Secondary as Secondary
import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types
  ( TraceCacheEvent
  , WithBlockSize (..)
  )
import Ouroboros.Consensus.Util.IOLike
import System.FS.API (HasFS)
import System.FS.API.Types (AllowExisting, Handle)

{------------------------------------------------------------------------------
  Index
------------------------------------------------------------------------------}

-- | Bundle the operations on the primary and secondary index that touch the
-- files. This allows us to easily introduce an intermediary caching layer.
data Index m blk h = Index
  { forall (m :: * -> *) blk h.
Index m blk h
-> forall (t :: * -> *).
   (HasCallStack, Traversable t) =>
   ChunkNo
   -> t RelativeSlot
   -> m (t (Maybe SecondaryOffset), Maybe (StrictSeq SecondaryOffset))
readOffsets ::
      forall t.
      (HasCallStack, Traversable t) =>
      ChunkNo ->
      t RelativeSlot ->
      m (t (Maybe SecondaryOffset), Maybe (StrictSeq SecondaryOffset))
  -- ^ See 'Primary.readOffsets'
  , forall (m :: * -> *) blk h.
Index m blk h -> HasCallStack => ChunkNo -> m (Maybe RelativeSlot)
readFirstFilledSlot ::
      HasCallStack =>
      ChunkNo ->
      m (Maybe RelativeSlot)
  -- ^  See 'Primary.readFirstFilledSlot'
  , forall (m :: * -> *) blk h.
Index m blk h
-> HasCallStack => ChunkNo -> AllowExisting -> m (Handle h)
openPrimaryIndex ::
      HasCallStack =>
      ChunkNo ->
      AllowExisting ->
      m (Handle h)
  -- ^ See 'Primary.open'
  , forall (m :: * -> *) blk h.
Index m blk h
-> forall (f :: * -> *).
   (HasCallStack, Foldable f) =>
   Handle h -> f SecondaryOffset -> m ()
appendOffsets ::
      forall f.
      (HasCallStack, Foldable f) =>
      Handle h ->
      f SecondaryOffset ->
      m ()
  -- ^ See 'Primary.appendOffsets'
  , forall (m :: * -> *) blk h.
Index m blk h
-> forall (t :: * -> *).
   (HasCallStack, Traversable t) =>
   ChunkNo
   -> t (IsEBB, SecondaryOffset) -> m (t (Entry blk, BlockSize))
readEntries ::
      forall t.
      (HasCallStack, Traversable t) =>
      ChunkNo ->
      t (IsEBB, SecondaryOffset) ->
      m (t (Secondary.Entry blk, BlockSize))
  -- ^ See 'Secondary.readEntries'
  , forall (m :: * -> *) blk h.
Index m blk h
-> HasCallStack =>
   SecondaryOffset
   -> ChunkNo
   -> (Entry blk -> Bool)
   -> Word64
   -> IsEBB
   -> m [WithBlockSize (Entry blk)]
readAllEntries ::
      HasCallStack =>
      SecondaryOffset ->
      ChunkNo ->
      (Secondary.Entry blk -> Bool) ->
      Word64 ->
      IsEBB ->
      m [WithBlockSize (Secondary.Entry blk)]
  -- ^ See 'Secondary.readAllEntries'
  , forall (m :: * -> *) blk h.
Index m blk h
-> HasCallStack =>
   ChunkNo -> Handle h -> WithBlockSize (Entry blk) -> m Word64
appendEntry ::
      HasCallStack =>
      ChunkNo ->
      Handle h ->
      WithBlockSize (Secondary.Entry blk) ->
      m Word64
  -- ^ See 'Secondary.appendEntry'
  , forall (m :: * -> *) blk h. Index m blk h -> HasCallStack => m ()
close ::
      HasCallStack =>
      m ()
  -- ^ Close the index and stop any background threads.
  --
  -- Should be called when the ImmutableDB is closed.
  , forall (m :: * -> *) blk h.
Index m blk h -> HasCallStack => ChunkNo -> m ()
restart ::
      HasCallStack =>
      ChunkNo ->
      m ()
  -- ^ Restart a closed index using the given chunk as the current chunk,
  -- drop all previously cached information.
  --
  -- NOTE: this will only used in the testsuite, when we need to truncate.
  }
  deriving Context -> Index m blk h -> IO (Maybe ThunkInfo)
Proxy (Index m blk h) -> String
(Context -> Index m blk h -> IO (Maybe ThunkInfo))
-> (Context -> Index m blk h -> IO (Maybe ThunkInfo))
-> (Proxy (Index m blk h) -> String)
-> NoThunks (Index m blk h)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (m :: * -> *) blk h.
Context -> Index m blk h -> IO (Maybe ThunkInfo)
forall (m :: * -> *) blk h. Proxy (Index m blk h) -> String
$cnoThunks :: forall (m :: * -> *) blk h.
Context -> Index m blk h -> IO (Maybe ThunkInfo)
noThunks :: Context -> Index m blk h -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *) blk h.
Context -> Index m blk h -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Index m blk h -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (m :: * -> *) blk h. Proxy (Index m blk h) -> String
showTypeOf :: Proxy (Index m blk h) -> String
NoThunks via OnlyCheckWhnfNamed "Index" (Index m blk h)

-- | See 'Primary.readOffset'.
readOffset ::
  Functor m =>
  Index m blk h ->
  ChunkNo ->
  RelativeSlot ->
  m (Maybe SecondaryOffset, Maybe (StrictSeq SecondaryOffset))
readOffset :: forall (m :: * -> *) blk h.
Functor m =>
Index m blk h
-> ChunkNo
-> RelativeSlot
-> m (Maybe SecondaryOffset, Maybe (StrictSeq SecondaryOffset))
readOffset Index m blk h
index ChunkNo
chunk RelativeSlot
slot =
  (\(Identity (Maybe SecondaryOffset)
x, Maybe (StrictSeq SecondaryOffset)
y) -> (Identity (Maybe SecondaryOffset) -> Maybe SecondaryOffset
forall a. Identity a -> a
runIdentity Identity (Maybe SecondaryOffset)
x, Maybe (StrictSeq SecondaryOffset)
y))
    ((Identity (Maybe SecondaryOffset),
  Maybe (StrictSeq SecondaryOffset))
 -> (Maybe SecondaryOffset, Maybe (StrictSeq SecondaryOffset)))
-> m (Identity (Maybe SecondaryOffset),
      Maybe (StrictSeq SecondaryOffset))
-> m (Maybe SecondaryOffset, Maybe (StrictSeq SecondaryOffset))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Index m blk h
-> forall (t :: * -> *).
   (HasCallStack, Traversable t) =>
   ChunkNo
   -> t RelativeSlot
   -> m (t (Maybe SecondaryOffset), Maybe (StrictSeq SecondaryOffset))
forall (m :: * -> *) blk h.
Index m blk h
-> forall (t :: * -> *).
   (HasCallStack, Traversable t) =>
   ChunkNo
   -> t RelativeSlot
   -> m (t (Maybe SecondaryOffset), Maybe (StrictSeq SecondaryOffset))
readOffsets Index m blk h
index ChunkNo
chunk (RelativeSlot -> Identity RelativeSlot
forall a. a -> Identity a
Identity RelativeSlot
slot)

-- | See 'Secondary.readEntry'.
readEntry ::
  Functor m =>
  Index m blk h ->
  ChunkNo ->
  IsEBB ->
  SecondaryOffset ->
  m (Secondary.Entry blk, BlockSize)
readEntry :: forall (m :: * -> *) blk h.
Functor m =>
Index m blk h
-> ChunkNo -> IsEBB -> SecondaryOffset -> m (Entry blk, BlockSize)
readEntry Index m blk h
index ChunkNo
chunk IsEBB
isEBB SecondaryOffset
slotOffset =
  Identity (Entry blk, BlockSize) -> (Entry blk, BlockSize)
forall a. Identity a -> a
runIdentity
    (Identity (Entry blk, BlockSize) -> (Entry blk, BlockSize))
-> m (Identity (Entry blk, BlockSize)) -> m (Entry blk, BlockSize)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Index m blk h
-> forall (t :: * -> *).
   (HasCallStack, Traversable t) =>
   ChunkNo
   -> t (IsEBB, SecondaryOffset) -> m (t (Entry blk, BlockSize))
forall (m :: * -> *) blk h.
Index m blk h
-> forall (t :: * -> *).
   (HasCallStack, Traversable t) =>
   ChunkNo
   -> t (IsEBB, SecondaryOffset) -> m (t (Entry blk, BlockSize))
readEntries Index m blk h
index ChunkNo
chunk ((IsEBB, SecondaryOffset) -> Identity (IsEBB, SecondaryOffset)
forall a. a -> Identity a
Identity (IsEBB
isEBB, SecondaryOffset
slotOffset))

{------------------------------------------------------------------------------
  File-backed index
------------------------------------------------------------------------------}

fileBackedIndex ::
  forall m blk h.
  (ConvertRawHash blk, MonadCatch m, StandardHash blk, Typeable blk) =>
  HasFS m h ->
  ChunkInfo ->
  Index m blk h
fileBackedIndex :: forall (m :: * -> *) blk h.
(ConvertRawHash blk, MonadCatch m, StandardHash blk,
 Typeable blk) =>
HasFS m h -> ChunkInfo -> Index m blk h
fileBackedIndex HasFS m h
hasFS ChunkInfo
chunkInfo =
  Index
    { readOffsets :: forall (t :: * -> *).
(HasCallStack, Traversable t) =>
ChunkNo
-> t RelativeSlot
-> m (t (Maybe SecondaryOffset), Maybe (StrictSeq SecondaryOffset))
readOffsets = \ChunkNo
x t RelativeSlot
y ->
        (,Maybe (StrictSeq SecondaryOffset)
forall a. Maybe a
Nothing)
          (t (Maybe SecondaryOffset)
 -> (t (Maybe SecondaryOffset), Maybe (StrictSeq SecondaryOffset)))
-> m (t (Maybe SecondaryOffset))
-> m (t (Maybe SecondaryOffset), Maybe (StrictSeq SecondaryOffset))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy blk
-> HasFS m h
-> ChunkNo
-> t RelativeSlot
-> m (t (Maybe SecondaryOffset))
forall blk (m :: * -> *) h (t :: * -> *).
(HasCallStack, MonadThrow m, Traversable t, StandardHash blk,
 Typeable blk) =>
Proxy blk
-> HasFS m h
-> ChunkNo
-> t RelativeSlot
-> m (t (Maybe SecondaryOffset))
Primary.readOffsets Proxy blk
p HasFS m h
hasFS ChunkNo
x t RelativeSlot
y
    , readFirstFilledSlot :: HasCallStack => ChunkNo -> m (Maybe RelativeSlot)
readFirstFilledSlot = Proxy blk
-> HasFS m h -> ChunkInfo -> ChunkNo -> m (Maybe RelativeSlot)
forall blk (m :: * -> *) h.
(HasCallStack, MonadThrow m, StandardHash blk, Typeable blk) =>
Proxy blk
-> HasFS m h -> ChunkInfo -> ChunkNo -> m (Maybe RelativeSlot)
Primary.readFirstFilledSlot Proxy blk
p HasFS m h
hasFS ChunkInfo
chunkInfo
    , openPrimaryIndex :: HasCallStack => ChunkNo -> AllowExisting -> m (Handle h)
openPrimaryIndex = HasFS m h -> ChunkNo -> AllowExisting -> m (Handle h)
forall (m :: * -> *) h.
(HasCallStack, MonadCatch m) =>
HasFS m h -> ChunkNo -> AllowExisting -> m (Handle h)
Primary.open HasFS m h
hasFS
    , appendOffsets :: forall (f :: * -> *).
(HasCallStack, Foldable f) =>
Handle h -> f SecondaryOffset -> m ()
appendOffsets = HasFS m h -> Handle h -> f SecondaryOffset -> m ()
forall (m :: * -> *) (f :: * -> *) h.
(Monad m, Foldable f, HasCallStack) =>
HasFS m h -> Handle h -> f SecondaryOffset -> m ()
Primary.appendOffsets HasFS m h
hasFS
    , readEntries :: forall (t :: * -> *).
(HasCallStack, Traversable t) =>
ChunkNo
-> t (IsEBB, SecondaryOffset) -> m (t (Entry blk, BlockSize))
readEntries = HasFS m h
-> ChunkNo
-> t (IsEBB, SecondaryOffset)
-> m (t (Entry blk, BlockSize))
forall (m :: * -> *) blk h (t :: * -> *).
(HasCallStack, ConvertRawHash blk, MonadThrow m, StandardHash blk,
 Typeable blk, Traversable t) =>
HasFS m h
-> ChunkNo
-> t (IsEBB, SecondaryOffset)
-> m (t (Entry blk, BlockSize))
Secondary.readEntries HasFS m h
hasFS
    , readAllEntries :: HasCallStack =>
SecondaryOffset
-> ChunkNo
-> (Entry blk -> Bool)
-> Word64
-> IsEBB
-> m [WithBlockSize (Entry blk)]
readAllEntries = HasFS m h
-> SecondaryOffset
-> ChunkNo
-> (Entry blk -> Bool)
-> Word64
-> IsEBB
-> m [WithBlockSize (Entry blk)]
forall (m :: * -> *) blk h.
(HasCallStack, ConvertRawHash blk, MonadThrow m, StandardHash blk,
 Typeable blk) =>
HasFS m h
-> SecondaryOffset
-> ChunkNo
-> (Entry blk -> Bool)
-> Word64
-> IsEBB
-> m [WithBlockSize (Entry blk)]
Secondary.readAllEntries HasFS m h
hasFS
    , appendEntry :: HasCallStack =>
ChunkNo -> Handle h -> WithBlockSize (Entry blk) -> m Word64
appendEntry = \ChunkNo
_chunk Handle h
h (WithBlockSize SecondaryOffset
_ Entry blk
entry) ->
        HasFS m h -> Handle h -> Entry blk -> m Word64
forall (m :: * -> *) blk h.
(HasCallStack, ConvertRawHash blk, MonadThrow m) =>
HasFS m h -> Handle h -> Entry blk -> m Word64
Secondary.appendEntry HasFS m h
hasFS Handle h
h Entry blk
entry
    , -- Nothing to do
      close :: HasCallStack => m ()
close = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    , restart :: HasCallStack => ChunkNo -> m ()
restart = \ChunkNo
_newCurChunk -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    }
 where
  p :: Proxy blk
  p :: Proxy blk
p = Proxy blk
forall {k} (t :: k). Proxy t
Proxy

{------------------------------------------------------------------------------
  Cached index
------------------------------------------------------------------------------}

-- | Caches the current chunk's indices as well as a number of past chunk's
-- indices.
--
-- Spawns a background thread to expire past chunks from the cache that
-- haven't been used for a while.
cachedIndex ::
  forall m blk h.
  (IOLike m, ConvertRawHash blk, StandardHash blk, Typeable blk) =>
  HasFS m h ->
  ResourceRegistry m ->
  Tracer m TraceCacheEvent ->
  CacheConfig ->
  ChunkInfo ->
  -- | Current chunk
  ChunkNo ->
  m (Index m blk h)
cachedIndex :: forall (m :: * -> *) blk h.
(IOLike m, ConvertRawHash blk, StandardHash blk, Typeable blk) =>
HasFS m h
-> ResourceRegistry m
-> Tracer m TraceCacheEvent
-> CacheConfig
-> ChunkInfo
-> ChunkNo
-> m (Index m blk h)
cachedIndex HasFS m h
hasFS ResourceRegistry m
registry Tracer m TraceCacheEvent
tracer CacheConfig
cacheConfig ChunkInfo
chunkInfo ChunkNo
chunk = do
  cacheEnv <-
    HasFS m h
-> ResourceRegistry m
-> Tracer m TraceCacheEvent
-> CacheConfig
-> ChunkInfo
-> ChunkNo
-> m (CacheEnv m blk h)
forall blk (m :: * -> *) h.
(HasCallStack, ConvertRawHash blk, IOLike m, StandardHash blk,
 Typeable blk) =>
HasFS m h
-> ResourceRegistry m
-> Tracer m TraceCacheEvent
-> CacheConfig
-> ChunkInfo
-> ChunkNo
-> m (CacheEnv m blk h)
Cache.newEnv
      HasFS m h
hasFS
      ResourceRegistry m
registry
      Tracer m TraceCacheEvent
tracer
      CacheConfig
cacheConfig
      ChunkInfo
chunkInfo
      ChunkNo
chunk
  return
    Index
      { readOffsets = Cache.readOffsets cacheEnv
      , readFirstFilledSlot = Cache.readFirstFilledSlot cacheEnv
      , openPrimaryIndex = Cache.openPrimaryIndex cacheEnv
      , appendOffsets = Cache.appendOffsets cacheEnv
      , readEntries = Cache.readEntries cacheEnv
      , readAllEntries = Cache.readAllEntries cacheEnv
      , appendEntry = Cache.appendEntry cacheEnv
      , close = Cache.close cacheEnv
      , restart = Cache.restart cacheEnv
      }