{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE DuplicateRecordFields      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiWayIf                 #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeApplications           #-}

module Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Cache (
    -- * Environment
    CacheConfig (..)
  , CacheEnv
  , checkInvariants
  , newEnv
    -- * Background thread
  , expireUnusedChunks
    -- * Operations
  , close
  , restart
    -- ** On the primary index
  , appendOffsets
  , openPrimaryIndex
  , readFirstFilledSlot
  , readOffsets
    -- ** On the secondary index
  , appendEntry
  , readAllEntries
  , readEntries
  ) where

import           Control.Exception (assert)
import           Control.Monad (forM, forM_, forever, mplus, unless, void, when)
import           Control.Monad.Except (throwError)
import           Control.Tracer (Tracer, traceWith)
import           Data.Foldable (toList)
import           Data.Functor ((<&>))
import           Data.IntPSQ (IntPSQ)
import qualified Data.IntPSQ as PSQ
import           Data.Maybe (fromMaybe)
import           Data.Proxy (Proxy (..))
import           Data.Sequence.Strict (StrictSeq)
import qualified Data.Sequence.Strict as Seq
import           Data.Typeable (Typeable)
import           Data.Vector (Vector)
import qualified Data.Vector as Vector
import           Data.Void (Void)
import           Data.Word (Word32, Word64)
import           GHC.Generics (Generic)
import           NoThunks.Class (unsafeNoThunks)

import           Cardano.Prelude (forceElemsToWHNF)

import           Ouroboros.Consensus.Block (ConvertRawHash, IsEBB (..),
                     StandardHash)
import           Ouroboros.Consensus.Util (takeUntil, whenJust)
import           Ouroboros.Consensus.Util.CallStack
import           Ouroboros.Consensus.Util.IOLike
import qualified Ouroboros.Consensus.Util.MonadSTM.StrictMVar as Strict
import           Ouroboros.Consensus.Util.ResourceRegistry

import           Ouroboros.Consensus.Storage.FS.API (HasFS (..), withFile)
import           Ouroboros.Consensus.Storage.FS.API.Types (AllowExisting (..),
                     Handle, OpenMode (ReadMode))

import           Ouroboros.Consensus.Storage.ImmutableDB.API
                     (UnexpectedFailure (..), throwUnexpectedFailure)
import           Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal
import           Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Layout
import           Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Primary
                     (PrimaryIndex, 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.Storage.ImmutableDB.Impl.Util
                     (fsPathChunkFile, fsPathPrimaryIndexFile,
                     fsPathSecondaryIndexFile)

-- TODO property and/or q-s-m tests comparing with 'fileBackedIndex'

{------------------------------------------------------------------------------
  Environment
------------------------------------------------------------------------------}

data CacheConfig = CacheConfig
  { CacheConfig -> Word32
pastChunksToCache :: Word32
    -- ^ Maximum number of past chunks to cache, excluding the current chunk.
    --
    -- NOTE: must be > 0
  , CacheConfig -> DiffTime
expireUnusedAfter :: DiffTime
    -- ^ Expire past chunks that haven't been used for 'expireUnusedAfter'
    -- from the cache, regardless the number of past chunks in the cache.
  }
  deriving (CacheConfig -> CacheConfig -> Bool
(CacheConfig -> CacheConfig -> Bool)
-> (CacheConfig -> CacheConfig -> Bool) -> Eq CacheConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CacheConfig -> CacheConfig -> Bool
$c/= :: CacheConfig -> CacheConfig -> Bool
== :: CacheConfig -> CacheConfig -> Bool
$c== :: CacheConfig -> CacheConfig -> Bool
Eq, Int -> CacheConfig -> ShowS
[CacheConfig] -> ShowS
CacheConfig -> String
(Int -> CacheConfig -> ShowS)
-> (CacheConfig -> String)
-> ([CacheConfig] -> ShowS)
-> Show CacheConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CacheConfig] -> ShowS
$cshowList :: [CacheConfig] -> ShowS
show :: CacheConfig -> String
$cshow :: CacheConfig -> String
showsPrec :: Int -> CacheConfig -> ShowS
$cshowsPrec :: Int -> CacheConfig -> ShowS
Show)

-- | Short-hand we use internally
type Entry blk = WithBlockSize (Secondary.Entry blk)

-- | The cached primary and secondary indices of the current chunk.
--
-- We use sequences (as opposed to vectors) to allow for efficient appending
-- in addition to (reasonably) efficient indexing.
data CurrentChunkInfo blk = CurrentChunkInfo
  { CurrentChunkInfo blk -> ChunkNo
currentChunkNo      :: !ChunkNo
  , CurrentChunkInfo blk -> StrictSeq Word32
currentChunkOffsets :: !(StrictSeq SecondaryOffset)
  , CurrentChunkInfo blk -> StrictSeq (Entry blk)
currentChunkEntries :: !(StrictSeq (Entry blk))
  }
  deriving (Int -> CurrentChunkInfo blk -> ShowS
[CurrentChunkInfo blk] -> ShowS
CurrentChunkInfo blk -> String
(Int -> CurrentChunkInfo blk -> ShowS)
-> (CurrentChunkInfo blk -> String)
-> ([CurrentChunkInfo blk] -> ShowS)
-> Show (CurrentChunkInfo blk)
forall blk.
StandardHash blk =>
Int -> CurrentChunkInfo blk -> ShowS
forall blk. StandardHash blk => [CurrentChunkInfo blk] -> ShowS
forall blk. StandardHash blk => CurrentChunkInfo blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CurrentChunkInfo blk] -> ShowS
$cshowList :: forall blk. StandardHash blk => [CurrentChunkInfo blk] -> ShowS
show :: CurrentChunkInfo blk -> String
$cshow :: forall blk. StandardHash blk => CurrentChunkInfo blk -> String
showsPrec :: Int -> CurrentChunkInfo blk -> ShowS
$cshowsPrec :: forall blk.
StandardHash blk =>
Int -> CurrentChunkInfo blk -> ShowS
Show, (forall x. CurrentChunkInfo blk -> Rep (CurrentChunkInfo blk) x)
-> (forall x. Rep (CurrentChunkInfo blk) x -> CurrentChunkInfo blk)
-> Generic (CurrentChunkInfo blk)
forall x. Rep (CurrentChunkInfo blk) x -> CurrentChunkInfo blk
forall x. CurrentChunkInfo blk -> Rep (CurrentChunkInfo blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (CurrentChunkInfo blk) x -> CurrentChunkInfo blk
forall blk x. CurrentChunkInfo blk -> Rep (CurrentChunkInfo blk) x
$cto :: forall blk x. Rep (CurrentChunkInfo blk) x -> CurrentChunkInfo blk
$cfrom :: forall blk x. CurrentChunkInfo blk -> Rep (CurrentChunkInfo blk) x
Generic, Context -> CurrentChunkInfo blk -> IO (Maybe ThunkInfo)
Proxy (CurrentChunkInfo blk) -> String
(Context -> CurrentChunkInfo blk -> IO (Maybe ThunkInfo))
-> (Context -> CurrentChunkInfo blk -> IO (Maybe ThunkInfo))
-> (Proxy (CurrentChunkInfo blk) -> String)
-> NoThunks (CurrentChunkInfo blk)
forall blk.
StandardHash blk =>
Context -> CurrentChunkInfo blk -> IO (Maybe ThunkInfo)
forall blk.
StandardHash blk =>
Proxy (CurrentChunkInfo blk) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (CurrentChunkInfo blk) -> String
$cshowTypeOf :: forall blk.
StandardHash blk =>
Proxy (CurrentChunkInfo blk) -> String
wNoThunks :: Context -> CurrentChunkInfo blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk.
StandardHash blk =>
Context -> CurrentChunkInfo blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> CurrentChunkInfo blk -> IO (Maybe ThunkInfo)
$cnoThunks :: forall blk.
StandardHash blk =>
Context -> CurrentChunkInfo blk -> IO (Maybe ThunkInfo)
NoThunks)

emptyCurrentChunkInfo :: ChunkNo -> CurrentChunkInfo blk
emptyCurrentChunkInfo :: ChunkNo -> CurrentChunkInfo blk
emptyCurrentChunkInfo ChunkNo
chunk = CurrentChunkInfo :: forall blk.
ChunkNo
-> StrictSeq Word32
-> StrictSeq (Entry blk)
-> CurrentChunkInfo blk
CurrentChunkInfo
  { $sel:currentChunkNo:CurrentChunkInfo :: ChunkNo
currentChunkNo      = ChunkNo
chunk
  , $sel:currentChunkOffsets:CurrentChunkInfo :: StrictSeq Word32
currentChunkOffsets = Word32 -> StrictSeq Word32
forall a. a -> StrictSeq a
Seq.singleton Word32
0
  , $sel:currentChunkEntries:CurrentChunkInfo :: StrictSeq (Entry blk)
currentChunkEntries = StrictSeq (Entry blk)
forall a. StrictSeq a
Seq.empty
  }

-- | Convert a 'CurrentChunkInfo' to a 'PastChunkInfo'
--
-- TODO don't bother with the conversion? Use vectors for past chunks at start
-- up. Chunks that become past chunks because we advance to new chunks, we can
-- just leave in memory as seqs?
toPastChunkInfo :: CurrentChunkInfo blk -> PastChunkInfo blk
toPastChunkInfo :: CurrentChunkInfo blk -> PastChunkInfo blk
toPastChunkInfo CurrentChunkInfo{StrictSeq Word32
StrictSeq (Entry blk)
ChunkNo
currentChunkEntries :: StrictSeq (Entry blk)
currentChunkOffsets :: StrictSeq Word32
currentChunkNo :: ChunkNo
$sel:currentChunkEntries:CurrentChunkInfo :: forall blk. CurrentChunkInfo blk -> StrictSeq (Entry blk)
$sel:currentChunkOffsets:CurrentChunkInfo :: forall blk. CurrentChunkInfo blk -> StrictSeq Word32
$sel:currentChunkNo:CurrentChunkInfo :: forall blk. CurrentChunkInfo blk -> ChunkNo
..} =
    PastChunkInfo :: forall blk. PrimaryIndex -> Vector (Entry blk) -> PastChunkInfo blk
PastChunkInfo
      { $sel:pastChunkOffsets:PastChunkInfo :: PrimaryIndex
pastChunkOffsets =
          PrimaryIndex -> Maybe PrimaryIndex -> PrimaryIndex
forall a. a -> Maybe a -> a
fromMaybe (String -> PrimaryIndex
forall a. HasCallStack => String -> a
error String
"invalid current chunk") (Maybe PrimaryIndex -> PrimaryIndex)
-> Maybe PrimaryIndex -> PrimaryIndex
forall a b. (a -> b) -> a -> b
$
          ChunkNo -> [Word32] -> Maybe PrimaryIndex
Primary.mk ChunkNo
currentChunkNo (StrictSeq Word32 -> [Word32]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq Word32
currentChunkOffsets)
      , $sel:pastChunkEntries:PastChunkInfo :: Vector (Entry blk)
pastChunkEntries =
          -- TODO optimise this
          [Entry blk] -> Vector (Entry blk)
forall a. [a] -> Vector a
Vector.fromList ([Entry blk] -> Vector (Entry blk))
-> [Entry blk] -> Vector (Entry blk)
forall a b. (a -> b) -> a -> b
$ StrictSeq (Entry blk) -> [Entry blk]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq (Entry blk)
currentChunkEntries
      }

-- | The cached primary and secondary indices of an chunk in the past.
--
-- We use vectors to allow for efficient indexing. We don't need to append to
-- them, as they are in the past and thus immutable.
data PastChunkInfo blk = PastChunkInfo
  { PastChunkInfo blk -> PrimaryIndex
pastChunkOffsets :: !PrimaryIndex
  , PastChunkInfo blk -> Vector (Entry blk)
pastChunkEntries :: !(Vector (Entry blk))
  }
  deriving ((forall x. PastChunkInfo blk -> Rep (PastChunkInfo blk) x)
-> (forall x. Rep (PastChunkInfo blk) x -> PastChunkInfo blk)
-> Generic (PastChunkInfo blk)
forall x. Rep (PastChunkInfo blk) x -> PastChunkInfo blk
forall x. PastChunkInfo blk -> Rep (PastChunkInfo blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (PastChunkInfo blk) x -> PastChunkInfo blk
forall blk x. PastChunkInfo blk -> Rep (PastChunkInfo blk) x
$cto :: forall blk x. Rep (PastChunkInfo blk) x -> PastChunkInfo blk
$cfrom :: forall blk x. PastChunkInfo blk -> Rep (PastChunkInfo blk) x
Generic, Context -> PastChunkInfo blk -> IO (Maybe ThunkInfo)
Proxy (PastChunkInfo blk) -> String
(Context -> PastChunkInfo blk -> IO (Maybe ThunkInfo))
-> (Context -> PastChunkInfo blk -> IO (Maybe ThunkInfo))
-> (Proxy (PastChunkInfo blk) -> String)
-> NoThunks (PastChunkInfo blk)
forall blk.
StandardHash blk =>
Context -> PastChunkInfo blk -> IO (Maybe ThunkInfo)
forall blk. StandardHash blk => Proxy (PastChunkInfo blk) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (PastChunkInfo blk) -> String
$cshowTypeOf :: forall blk. StandardHash blk => Proxy (PastChunkInfo blk) -> String
wNoThunks :: Context -> PastChunkInfo blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk.
StandardHash blk =>
Context -> PastChunkInfo blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> PastChunkInfo blk -> IO (Maybe ThunkInfo)
$cnoThunks :: forall blk.
StandardHash blk =>
Context -> PastChunkInfo blk -> IO (Maybe ThunkInfo)
NoThunks)

-- | The last time a cached past chunk was accessed.
--
-- We care about the ordering /and/ the absolute times so we can also evict
-- chunks when they haven't been used for @x@ seconds or minutes.
newtype LastUsed = LastUsed Time
  deriving newtype (LastUsed -> LastUsed -> Bool
(LastUsed -> LastUsed -> Bool)
-> (LastUsed -> LastUsed -> Bool) -> Eq LastUsed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LastUsed -> LastUsed -> Bool
$c/= :: LastUsed -> LastUsed -> Bool
== :: LastUsed -> LastUsed -> Bool
$c== :: LastUsed -> LastUsed -> Bool
Eq, Eq LastUsed
Eq LastUsed
-> (LastUsed -> LastUsed -> Ordering)
-> (LastUsed -> LastUsed -> Bool)
-> (LastUsed -> LastUsed -> Bool)
-> (LastUsed -> LastUsed -> Bool)
-> (LastUsed -> LastUsed -> Bool)
-> (LastUsed -> LastUsed -> LastUsed)
-> (LastUsed -> LastUsed -> LastUsed)
-> Ord LastUsed
LastUsed -> LastUsed -> Bool
LastUsed -> LastUsed -> Ordering
LastUsed -> LastUsed -> LastUsed
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LastUsed -> LastUsed -> LastUsed
$cmin :: LastUsed -> LastUsed -> LastUsed
max :: LastUsed -> LastUsed -> LastUsed
$cmax :: LastUsed -> LastUsed -> LastUsed
>= :: LastUsed -> LastUsed -> Bool
$c>= :: LastUsed -> LastUsed -> Bool
> :: LastUsed -> LastUsed -> Bool
$c> :: LastUsed -> LastUsed -> Bool
<= :: LastUsed -> LastUsed -> Bool
$c<= :: LastUsed -> LastUsed -> Bool
< :: LastUsed -> LastUsed -> Bool
$c< :: LastUsed -> LastUsed -> Bool
compare :: LastUsed -> LastUsed -> Ordering
$ccompare :: LastUsed -> LastUsed -> Ordering
$cp1Ord :: Eq LastUsed
Ord, Int -> LastUsed -> ShowS
[LastUsed] -> ShowS
LastUsed -> String
(Int -> LastUsed -> ShowS)
-> (LastUsed -> String) -> ([LastUsed] -> ShowS) -> Show LastUsed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LastUsed] -> ShowS
$cshowList :: [LastUsed] -> ShowS
show :: LastUsed -> String
$cshow :: LastUsed -> String
showsPrec :: Int -> LastUsed -> ShowS
$cshowsPrec :: Int -> LastUsed -> ShowS
Show, Context -> LastUsed -> IO (Maybe ThunkInfo)
Proxy LastUsed -> String
(Context -> LastUsed -> IO (Maybe ThunkInfo))
-> (Context -> LastUsed -> IO (Maybe ThunkInfo))
-> (Proxy LastUsed -> String)
-> NoThunks LastUsed
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy LastUsed -> String
$cshowTypeOf :: Proxy LastUsed -> String
wNoThunks :: Context -> LastUsed -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> LastUsed -> IO (Maybe ThunkInfo)
noThunks :: Context -> LastUsed -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> LastUsed -> IO (Maybe ThunkInfo)
NoThunks)

-- | The data stored in the cache.
data Cached blk = Cached
  { Cached blk -> ChunkNo
currentChunk     :: !ChunkNo
    -- ^ The current chunk of the ImmutableDB, i.e., the chunk we're still
    -- appending entries too.
  , Cached blk -> CurrentChunkInfo blk
currentChunkInfo :: !(CurrentChunkInfo blk)
    -- ^ We always cache the current chunk.
    --
    -- When clients are in sync with our chain, they will only request blocks
    -- from the current chunk, so it is worth optimising this case.
    -- Additionally, by appending to the current chunk through the cache, we
    -- are sure the current chunk info is never stale.
    --
    -- We use an 'IntPSQ' here, where the keys are in fact chunk numbers. Since
    -- chunk numbers are internally represented by a 'Word64', one might be worried
    -- about a potential overflow here. While possible, it's not worth worrying about:
    -- - Whilst guaranteed to be only at least 30 bits, in practice, 64-bit GHC has 64-bit
    --   integers, so the conversion is bijective.
    -- - An chunk currently lasts around a week. Systems using a smaller representation
    --   might need to worry in a million years or so.
    -- - In the event of running for a million years, we're unlikely to have a problem anyway,
    --   since we only really cache _recent_ chunks. So the fact that they clash with the
    --   chunks from a million years ago isn't likely to be an issue.
  , Cached blk -> IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo   :: !(IntPSQ LastUsed (PastChunkInfo blk))
    -- ^ Cached chunks from the past.
    --
    -- A LRU-cache (least recently used). Whenever a we get a cache hit
    -- ('getChunkInfo') for a past chunk, we change its 'LastUsed' priority to
    -- the current time. When the cache is full, see 'pastChunksToCache', we
    -- will remove the chunk with the lowest priority, i.e. the least recently
    -- used past chunk.
    --
    -- INVARIANT: all past chunks are < 'currentChunk'
    --
    -- INVARIANT: @'PSQ.size' 'pastChunksInfo' <= 'pastChunksToCache'@
  , Cached blk -> Word32
nbPastChunks     :: !Word32
    -- ^ Cached size of 'pastChunksInfo', as an 'IntPSQ' only provides a \(O(n)
    -- \) 'PSQ.size' operation.
    --
    -- INVARIANT: 'nbPastChunks' == @'PSQ.size' 'pastChunksInfo'@
  }
  deriving ((forall x. Cached blk -> Rep (Cached blk) x)
-> (forall x. Rep (Cached blk) x -> Cached blk)
-> Generic (Cached blk)
forall x. Rep (Cached blk) x -> Cached blk
forall x. Cached blk -> Rep (Cached blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (Cached blk) x -> Cached blk
forall blk x. Cached blk -> Rep (Cached blk) x
$cto :: forall blk x. Rep (Cached blk) x -> Cached blk
$cfrom :: forall blk x. Cached blk -> Rep (Cached blk) x
Generic, Context -> Cached blk -> IO (Maybe ThunkInfo)
Proxy (Cached blk) -> String
(Context -> Cached blk -> IO (Maybe ThunkInfo))
-> (Context -> Cached blk -> IO (Maybe ThunkInfo))
-> (Proxy (Cached blk) -> String)
-> NoThunks (Cached blk)
forall blk.
StandardHash blk =>
Context -> Cached blk -> IO (Maybe ThunkInfo)
forall blk. StandardHash blk => Proxy (Cached blk) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (Cached blk) -> String
$cshowTypeOf :: forall blk. StandardHash blk => Proxy (Cached blk) -> String
wNoThunks :: Context -> Cached blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk.
StandardHash blk =>
Context -> Cached blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> Cached blk -> IO (Maybe ThunkInfo)
$cnoThunks :: forall blk.
StandardHash blk =>
Context -> Cached blk -> IO (Maybe ThunkInfo)
NoThunks)

checkInvariants
  :: Word32  -- ^ Maximum number of past chunks to cache
  -> Cached blk
  -> Maybe String
checkInvariants :: Word32 -> Cached blk -> Maybe String
checkInvariants Word32
pastChunksToCache Cached {Word32
IntPSQ LastUsed (PastChunkInfo blk)
ChunkNo
CurrentChunkInfo blk
nbPastChunks :: Word32
pastChunksInfo :: IntPSQ LastUsed (PastChunkInfo blk)
currentChunkInfo :: CurrentChunkInfo blk
currentChunk :: ChunkNo
$sel:nbPastChunks:Cached :: forall blk. Cached blk -> Word32
$sel:pastChunksInfo:Cached :: forall blk. Cached blk -> IntPSQ LastUsed (PastChunkInfo blk)
$sel:currentChunkInfo:Cached :: forall blk. Cached blk -> CurrentChunkInfo blk
$sel:currentChunk:Cached :: forall blk. Cached blk -> ChunkNo
..} = (String -> Maybe String)
-> (() -> Maybe String) -> Either String () -> Maybe String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Maybe String
forall a. a -> Maybe a
Just (Maybe String -> () -> Maybe String
forall a b. a -> b -> a
const Maybe String
forall a. Maybe a
Nothing) (Either String () -> Maybe String)
-> Either String () -> Maybe String
forall a b. (a -> b) -> a -> b
$ do
    [Int] -> (Int -> Either String ()) -> Either String ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (IntPSQ LastUsed (PastChunkInfo blk) -> [Int]
forall p v. IntPSQ p v -> [Int]
PSQ.keys IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo) ((Int -> Either String ()) -> Either String ())
-> (Int -> Either String ()) -> Either String ()
forall a b. (a -> b) -> a -> b
$ \Int
pastChunk ->
      Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
pastChunk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< ChunkNo -> Int
chunkNoToInt ChunkNo
currentChunk) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
        String -> Either String ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
          String
"past chunk (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
pastChunk String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
") >= current chunk (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
          ChunkNo -> String
forall a. Show a => a -> String
show ChunkNo
currentChunk String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"

    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (IntPSQ LastUsed (PastChunkInfo blk) -> Int
forall p v. IntPSQ p v -> Int
PSQ.size IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
pastChunksToCache) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
      String -> Either String ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
        String
"PSQ.size pastChunksInfo (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (IntPSQ LastUsed (PastChunkInfo blk) -> Int
forall p v. IntPSQ p v -> Int
PSQ.size IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo) String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
        String
") > pastChunksToCache (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word32 -> String
forall a. Show a => a -> String
show Word32
pastChunksToCache String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"

    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word32
nbPastChunks Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IntPSQ LastUsed (PastChunkInfo blk) -> Int
forall p v. IntPSQ p v -> Int
PSQ.size IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo)) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
      String -> Either String ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
        String
"nbPastChunks (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word32 -> String
forall a. Show a => a -> String
show Word32
nbPastChunks String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
        String
") /= PSQ.size pastChunksInfo (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (IntPSQ LastUsed (PastChunkInfo blk) -> Int
forall p v. IntPSQ p v -> Int
PSQ.size IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo) String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
        String
")"


-- | Store the 'PastChunkInfo' for the given 'ChunkNo' in 'Cached'.
--
-- Uses the 'LastUsed' as the priority.
--
-- NOTE: does not trim the cache.
--
-- PRECONDITION: the given 'ChunkNo' is < the 'currentChunk'.
addPastChunkInfo
  :: ChunkNo
  -> LastUsed
  -> PastChunkInfo blk
  -> Cached blk
  -> Cached blk
addPastChunkInfo :: ChunkNo
-> LastUsed -> PastChunkInfo blk -> Cached blk -> Cached blk
addPastChunkInfo ChunkNo
chunk LastUsed
lastUsed PastChunkInfo blk
pastChunkInfo Cached blk
cached =
    Bool -> Cached blk -> Cached blk
forall a. HasCallStack => Bool -> a -> a
assert (ChunkNo
chunk ChunkNo -> ChunkNo -> Bool
forall a. Ord a => a -> a -> Bool
< Cached blk -> ChunkNo
forall blk. Cached blk -> ChunkNo
currentChunk Cached blk
cached) (Cached blk -> Cached blk) -> Cached blk -> Cached blk
forall a b. (a -> b) -> a -> b
$
    -- NOTE: in case of multiple concurrent cache misses of the same chunk,
    -- we might add the same past chunk multiple times to the cache. This
    -- means the following cannot be a precondition:
    -- assert (not (PSQ.member chunk pastChunksInfo)) $
    Cached blk
cached
      { $sel:pastChunksInfo:Cached :: IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo = IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo'
      , $sel:nbPastChunks:Cached :: Word32
nbPastChunks   = Word32
nbPastChunks'
      }
  where
    Cached { IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo :: IntPSQ LastUsed (PastChunkInfo blk)
$sel:pastChunksInfo:Cached :: forall blk. Cached blk -> IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo, Word32
nbPastChunks :: Word32
$sel:nbPastChunks:Cached :: forall blk. Cached blk -> Word32
nbPastChunks } = Cached blk
cached

    -- In case of multiple concurrent cache misses of the same chunk, the
    -- chunk might already be in there.
    (Maybe (LastUsed, PastChunkInfo blk)
mbAlreadyPresent, IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo') =
      Int
-> LastUsed
-> PastChunkInfo blk
-> IntPSQ LastUsed (PastChunkInfo blk)
-> (Maybe (LastUsed, PastChunkInfo blk),
    IntPSQ LastUsed (PastChunkInfo blk))
forall p v.
Ord p =>
Int -> p -> v -> IntPSQ p v -> (Maybe (p, v), IntPSQ p v)
PSQ.insertView (ChunkNo -> Int
chunkNoToInt ChunkNo
chunk) LastUsed
lastUsed PastChunkInfo blk
pastChunkInfo IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo

    nbPastChunks' :: Word32
nbPastChunks'
      | Just (LastUsed, PastChunkInfo blk)
_ <- Maybe (LastUsed, PastChunkInfo blk)
mbAlreadyPresent
      = Word32
nbPastChunks
      | Bool
otherwise
      = Word32 -> Word32
forall a. Enum a => a -> a
succ Word32
nbPastChunks

-- | Remove the least recently used past chunk from the cache when 'Cached'
-- contains more chunks than the given maximum.
--
-- PRECONDITION: 'nbPastChunks' + 1 <= given maximum. In other words, 'Cached'
-- contains at most one chunk too many. We ensure this by calling this
-- function directly after adding a past chunk to 'Cached'.
--
-- If a past chunk was evicted, its chunk number is returned.
evictIfNecessary
  :: Word32  -- ^ Maximum number of past chunks to cache
  -> Cached blk
  -> (Cached blk, Maybe ChunkNo)
evictIfNecessary :: Word32 -> Cached blk -> (Cached blk, Maybe ChunkNo)
evictIfNecessary Word32
maxNbPastChunks Cached blk
cached
    | Word32
nbPastChunks Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
maxNbPastChunks
    = Bool -> (Cached blk, Maybe ChunkNo) -> (Cached blk, Maybe ChunkNo)
forall a. HasCallStack => Bool -> a -> a
assert (Word32
nbPastChunks Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
maxNbPastChunks Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1) ((Cached blk, Maybe ChunkNo) -> (Cached blk, Maybe ChunkNo))
-> (Cached blk, Maybe ChunkNo) -> (Cached blk, Maybe ChunkNo)
forall a b. (a -> b) -> a -> b
$
      case IntPSQ LastUsed (PastChunkInfo blk)
-> Maybe
     (Int, LastUsed, PastChunkInfo blk,
      IntPSQ LastUsed (PastChunkInfo blk))
forall p v. Ord p => IntPSQ p v -> Maybe (Int, p, v, IntPSQ p v)
PSQ.minView IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo of
        Maybe
  (Int, LastUsed, PastChunkInfo blk,
   IntPSQ LastUsed (PastChunkInfo blk))
Nothing                                 -> String -> (Cached blk, Maybe ChunkNo)
forall a. HasCallStack => String -> a
error
          String
"nbPastChunks > maxNbPastChunks but pastChunksInfo was empty"
        Just (Int
chunkNo, LastUsed
_p, PastChunkInfo blk
_v, IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo') ->
            (Cached blk
cached', ChunkNo -> Maybe ChunkNo
forall a. a -> Maybe a
Just (ChunkNo -> Maybe ChunkNo) -> ChunkNo -> Maybe ChunkNo
forall a b. (a -> b) -> a -> b
$ Int -> ChunkNo
chunkNoFromInt Int
chunkNo)
          where
            cached' :: Cached blk
cached' = Cached blk
cached
              { $sel:nbPastChunks:Cached :: Word32
nbPastChunks   = Word32
maxNbPastChunks
              , $sel:pastChunksInfo:Cached :: IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo = IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo'
              }
    | Bool
otherwise
    = (Cached blk
cached, Maybe ChunkNo
forall a. Maybe a
Nothing)
  where
    Cached { Word32
nbPastChunks :: Word32
$sel:nbPastChunks:Cached :: forall blk. Cached blk -> Word32
nbPastChunks, IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo :: IntPSQ LastUsed (PastChunkInfo blk)
$sel:pastChunksInfo:Cached :: forall blk. Cached blk -> IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo } = Cached blk
cached
-- NOTE: we must inline 'evictIfNecessary' otherwise we get unexplained thunks
-- in 'Cached' and thus a space leak. Alternatively, we could disable the
-- @-fstrictness@ optimisation (enabled by default for -O1).
{-# INLINE evictIfNecessary #-}

lookupPastChunkInfo
  :: ChunkNo
  -> LastUsed
  -> Cached blk
  -> Maybe (PastChunkInfo blk, Cached blk)
lookupPastChunkInfo :: ChunkNo
-> LastUsed -> Cached blk -> Maybe (PastChunkInfo blk, Cached blk)
lookupPastChunkInfo ChunkNo
chunk LastUsed
lastUsed cached :: Cached blk
cached@Cached { IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo :: IntPSQ LastUsed (PastChunkInfo blk)
$sel:pastChunksInfo:Cached :: forall blk. Cached blk -> IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo } =
    case (Maybe (LastUsed, PastChunkInfo blk)
 -> (Maybe (PastChunkInfo blk),
     Maybe (LastUsed, PastChunkInfo blk)))
-> Int
-> IntPSQ LastUsed (PastChunkInfo blk)
-> (Maybe (PastChunkInfo blk), IntPSQ LastUsed (PastChunkInfo blk))
forall p v b.
Ord p =>
(Maybe (p, v) -> (b, Maybe (p, v)))
-> Int -> IntPSQ p v -> (b, IntPSQ p v)
PSQ.alter Maybe (LastUsed, PastChunkInfo blk)
-> (Maybe (PastChunkInfo blk), Maybe (LastUsed, PastChunkInfo blk))
forall blk.
Maybe (LastUsed, PastChunkInfo blk)
-> (Maybe (PastChunkInfo blk), Maybe (LastUsed, PastChunkInfo blk))
lookupAndUpdateLastUsed (ChunkNo -> Int
chunkNoToInt ChunkNo
chunk) IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo of
      (Maybe (PastChunkInfo blk)
Nothing, IntPSQ LastUsed (PastChunkInfo blk)
_) -> Maybe (PastChunkInfo blk, Cached blk)
forall a. Maybe a
Nothing
      (Just PastChunkInfo blk
pastChunkInfo, IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo') -> (PastChunkInfo blk, Cached blk)
-> Maybe (PastChunkInfo blk, Cached blk)
forall a. a -> Maybe a
Just (PastChunkInfo blk
pastChunkInfo, Cached blk
cached')
        where
          cached' :: Cached blk
cached' = Cached blk
cached { $sel:pastChunksInfo:Cached :: IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo = IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo' }
  where
    lookupAndUpdateLastUsed
      :: Maybe (LastUsed, PastChunkInfo blk)
      -> (Maybe (PastChunkInfo blk), Maybe (LastUsed, PastChunkInfo blk))
    lookupAndUpdateLastUsed :: Maybe (LastUsed, PastChunkInfo blk)
-> (Maybe (PastChunkInfo blk), Maybe (LastUsed, PastChunkInfo blk))
lookupAndUpdateLastUsed = \case
      Maybe (LastUsed, PastChunkInfo blk)
Nothing                -> (Maybe (PastChunkInfo blk)
forall a. Maybe a
Nothing, Maybe (LastUsed, PastChunkInfo blk)
forall a. Maybe a
Nothing)
      Just (LastUsed
_lastUsed, PastChunkInfo blk
info) -> (PastChunkInfo blk -> Maybe (PastChunkInfo blk)
forall a. a -> Maybe a
Just PastChunkInfo blk
info, (LastUsed, PastChunkInfo blk)
-> Maybe (LastUsed, PastChunkInfo blk)
forall a. a -> Maybe a
Just (LastUsed
lastUsed, PastChunkInfo blk
info))

openChunk
  :: ChunkNo
  -> LastUsed
  -> CurrentChunkInfo blk
  -> Cached blk
  -> Cached blk
openChunk :: ChunkNo
-> LastUsed -> CurrentChunkInfo blk -> Cached blk -> Cached blk
openChunk ChunkNo
chunk LastUsed
lastUsed CurrentChunkInfo blk
newCurrentChunkInfo Cached blk
cached
    | ChunkNo
currentChunk ChunkNo -> ChunkNo -> Bool
forall a. Eq a => a -> a -> Bool
== ChunkNo
chunk
    = Cached blk
cached
        { $sel:currentChunkInfo:Cached :: CurrentChunkInfo blk
currentChunkInfo = CurrentChunkInfo blk
newCurrentChunkInfo }

    | ChunkNo -> ChunkNo
nextChunkNo ChunkNo
currentChunk ChunkNo -> ChunkNo -> Bool
forall a. Eq a => a -> a -> Bool
== ChunkNo
chunk
    = Cached :: forall blk.
ChunkNo
-> CurrentChunkInfo blk
-> IntPSQ LastUsed (PastChunkInfo blk)
-> Word32
-> Cached blk
Cached
        { $sel:currentChunk:Cached :: ChunkNo
currentChunk     = ChunkNo
chunk
        , $sel:currentChunkInfo:Cached :: CurrentChunkInfo blk
currentChunkInfo = CurrentChunkInfo blk
newCurrentChunkInfo
          -- We use 'lastUsed' for the current chunk that has now become a
          -- "past" chunk, which means that that chunk is most recently used
          -- one. When clients are roughly in sync with us, when we switch to a
          -- new chunk, they might still request blocks from the previous one.
          -- So to avoid throwing away that cached information, we give it the
          -- highest priority.
        , $sel:pastChunksInfo:Cached :: IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo   = Int
-> LastUsed
-> PastChunkInfo blk
-> IntPSQ LastUsed (PastChunkInfo blk)
-> IntPSQ LastUsed (PastChunkInfo blk)
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
PSQ.insert (ChunkNo -> Int
chunkNoToInt ChunkNo
currentChunk) LastUsed
lastUsed
            (CurrentChunkInfo blk -> PastChunkInfo blk
forall blk. CurrentChunkInfo blk -> PastChunkInfo blk
toPastChunkInfo CurrentChunkInfo blk
currentChunkInfo) IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo
        , $sel:nbPastChunks:Cached :: Word32
nbPastChunks     = Word32 -> Word32
forall a. Enum a => a -> a
succ Word32
nbPastChunks
        }

    | Bool
otherwise
    = String -> Cached blk
forall a. HasCallStack => String -> a
error (String -> Cached blk) -> String -> Cached blk
forall a b. (a -> b) -> a -> b
$ String
"Going from chunk " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ChunkNo -> String
forall a. Show a => a -> String
show ChunkNo
currentChunk String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" to " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ChunkNo -> String
forall a. Show a => a -> String
show ChunkNo
chunk
  where
    Cached
      { ChunkNo
currentChunk :: ChunkNo
$sel:currentChunk:Cached :: forall blk. Cached blk -> ChunkNo
currentChunk, CurrentChunkInfo blk
currentChunkInfo :: CurrentChunkInfo blk
$sel:currentChunkInfo:Cached :: forall blk. Cached blk -> CurrentChunkInfo blk
currentChunkInfo, IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo :: IntPSQ LastUsed (PastChunkInfo blk)
$sel:pastChunksInfo:Cached :: forall blk. Cached blk -> IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo, Word32
nbPastChunks :: Word32
$sel:nbPastChunks:Cached :: forall blk. Cached blk -> Word32
nbPastChunks
      } = Cached blk
cached

emptyCached
  :: ChunkNo -- ^ The current chunk
  -> CurrentChunkInfo blk
  -> Cached blk
emptyCached :: ChunkNo -> CurrentChunkInfo blk -> Cached blk
emptyCached ChunkNo
currentChunk CurrentChunkInfo blk
currentChunkInfo = Cached :: forall blk.
ChunkNo
-> CurrentChunkInfo blk
-> IntPSQ LastUsed (PastChunkInfo blk)
-> Word32
-> Cached blk
Cached
    { ChunkNo
currentChunk :: ChunkNo
$sel:currentChunk:Cached :: ChunkNo
currentChunk
    , CurrentChunkInfo blk
currentChunkInfo :: CurrentChunkInfo blk
$sel:currentChunkInfo:Cached :: CurrentChunkInfo blk
currentChunkInfo
    , $sel:pastChunksInfo:Cached :: IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo = IntPSQ LastUsed (PastChunkInfo blk)
forall p v. IntPSQ p v
PSQ.empty
    , $sel:nbPastChunks:Cached :: Word32
nbPastChunks   = Word32
0
    }

-- | Environment used by functions operating on the cached index.
data CacheEnv m blk h = CacheEnv
  { CacheEnv m blk h -> HasFS m h
hasFS       :: HasFS m h
  , CacheEnv m blk h -> ResourceRegistry m
registry    :: ResourceRegistry m
  , CacheEnv m blk h -> Tracer m TraceCacheEvent
tracer      :: Tracer m TraceCacheEvent
  , CacheEnv m blk h -> StrictMVar m (Cached blk)
cacheVar    :: StrictMVar m (Cached blk)
  , CacheEnv m blk h -> CacheConfig
cacheConfig :: CacheConfig
  , CacheEnv m blk h -> StrictMVar m (Maybe (Thread m Void))
bgThreadVar :: StrictMVar m (Maybe (Thread m Void))
    -- ^ Nothing if no thread running
  , CacheEnv m blk h -> ChunkInfo
chunkInfo   :: ChunkInfo
  }

-- | Creates a new 'CacheEnv' and launches a background thread that expires
-- unused past chunks ('expireUnusedChunks').
--
-- PRECONDITION: 'pastChunksToCache' (in 'CacheConfig') > 0
newEnv
  :: ( HasCallStack
     , ConvertRawHash blk
     , IOLike m
     , StandardHash blk
     , Typeable blk
     )
  => HasFS m h
  -> ResourceRegistry m
  -> Tracer m TraceCacheEvent
  -> CacheConfig
  -> ChunkInfo
  -> ChunkNo  -- ^ Current chunk
  -> m (CacheEnv m blk h)
newEnv :: HasFS m h
-> ResourceRegistry m
-> Tracer m TraceCacheEvent
-> CacheConfig
-> ChunkInfo
-> ChunkNo
-> m (CacheEnv m blk h)
newEnv HasFS m h
hasFS ResourceRegistry m
registry Tracer m TraceCacheEvent
tracer CacheConfig
cacheConfig ChunkInfo
chunkInfo ChunkNo
chunk = do
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
pastChunksToCache Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      String -> m ()
forall a. HasCallStack => String -> a
error String
"pastChunksToCache must be > 0"

    CurrentChunkInfo blk
currentChunkInfo <- HasFS m h -> ChunkInfo -> ChunkNo -> m (CurrentChunkInfo blk)
forall (m :: * -> *) h blk.
(HasCallStack, ConvertRawHash blk, IOLike m, StandardHash blk,
 Typeable blk) =>
HasFS m h -> ChunkInfo -> ChunkNo -> m (CurrentChunkInfo blk)
loadCurrentChunkInfo HasFS m h
hasFS ChunkInfo
chunkInfo ChunkNo
chunk
    StrictMVar m (Cached blk)
cacheVar <- Cached blk -> m (StrictMVar m (Cached blk))
newMVarWithInvariants (Cached blk -> m (StrictMVar m (Cached blk)))
-> Cached blk -> m (StrictMVar m (Cached blk))
forall a b. (a -> b) -> a -> b
$ ChunkNo -> CurrentChunkInfo blk -> Cached blk
forall blk. ChunkNo -> CurrentChunkInfo blk -> Cached blk
emptyCached ChunkNo
chunk CurrentChunkInfo blk
currentChunkInfo
    StrictMVar m (Maybe (Thread m Void))
bgThreadVar <- Maybe (Thread m Void) -> m (StrictMVar m (Maybe (Thread m Void)))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictMVar m a)
newMVar Maybe (Thread m Void)
forall a. Maybe a
Nothing
    let cacheEnv :: CacheEnv m blk h
cacheEnv = CacheEnv :: forall (m :: * -> *) blk h.
HasFS m h
-> ResourceRegistry m
-> Tracer m TraceCacheEvent
-> StrictMVar m (Cached blk)
-> CacheConfig
-> StrictMVar m (Maybe (Thread m Void))
-> ChunkInfo
-> CacheEnv m blk h
CacheEnv {Tracer m TraceCacheEvent
HasFS m h
StrictMVar m (Maybe (Thread m Void))
StrictMVar m (Cached blk)
ChunkInfo
ResourceRegistry m
CacheConfig
bgThreadVar :: StrictMVar m (Maybe (Thread m Void))
cacheVar :: StrictMVar m (Cached blk)
chunkInfo :: ChunkInfo
cacheConfig :: CacheConfig
tracer :: Tracer m TraceCacheEvent
registry :: ResourceRegistry m
hasFS :: HasFS m h
$sel:chunkInfo:CacheEnv :: ChunkInfo
$sel:bgThreadVar:CacheEnv :: StrictMVar m (Maybe (Thread m Void))
$sel:cacheConfig:CacheEnv :: CacheConfig
$sel:cacheVar:CacheEnv :: StrictMVar m (Cached blk)
$sel:tracer:CacheEnv :: Tracer m TraceCacheEvent
$sel:registry:CacheEnv :: ResourceRegistry m
$sel:hasFS:CacheEnv :: HasFS m h
..}
    m () -> m ()
forall (m :: * -> *) a. MonadMask m => m a -> m a
mask_ (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictMVar m (Maybe (Thread m Void))
-> (Maybe (Thread m Void) -> m (Maybe (Thread m Void))) -> m ()
forall (m :: * -> *) a.
(MonadSTM m, MonadCatch m, HasCallStack) =>
StrictMVar m a -> (a -> m a) -> m ()
modifyMVar_ StrictMVar m (Maybe (Thread m Void))
bgThreadVar ((Maybe (Thread m Void) -> m (Maybe (Thread m Void))) -> m ())
-> (Maybe (Thread m Void) -> m (Maybe (Thread m Void))) -> m ()
forall a b. (a -> b) -> a -> b
$ \Maybe (Thread m Void)
_mustBeNothing -> do
      !Thread m Void
bgThread <- ResourceRegistry m -> String -> m Void -> m (Thread m Void)
forall (m :: * -> *) a.
(IOLike m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry String
"ImmutableDB.expireUnusedChunks" (m Void -> m (Thread m Void)) -> m Void -> m (Thread m Void)
forall a b. (a -> b) -> a -> b
$
        CacheEnv m blk h -> m Void
forall (m :: * -> *) blk h.
(HasCallStack, IOLike m) =>
CacheEnv m blk h -> m Void
expireUnusedChunks CacheEnv m blk h
cacheEnv
      Maybe (Thread m Void) -> m (Maybe (Thread m Void))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Thread m Void) -> m (Maybe (Thread m Void)))
-> Maybe (Thread m Void) -> m (Maybe (Thread m Void))
forall a b. (a -> b) -> a -> b
$ Thread m Void -> Maybe (Thread m Void)
forall a. a -> Maybe a
Just Thread m Void
bgThread
    CacheEnv m blk h -> m (CacheEnv m blk h)
forall (m :: * -> *) a. Monad m => a -> m a
return CacheEnv m blk h
cacheEnv
  where
    CacheConfig { Word32
pastChunksToCache :: Word32
$sel:pastChunksToCache:CacheConfig :: CacheConfig -> Word32
pastChunksToCache } = CacheConfig
cacheConfig

    -- When checking invariants, check both our invariants and for thunks.
    -- Note that this is only done when the corresponding flag is enabled.
    newMVarWithInvariants :: Cached blk -> m (StrictMVar m (Cached blk))
newMVarWithInvariants =
      (Cached blk -> Maybe String)
-> Cached blk -> m (StrictMVar m (Cached blk))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
(a -> Maybe String) -> a -> m (StrictMVar m a)
Strict.newMVarWithInvariant ((Cached blk -> Maybe String)
 -> Cached blk -> m (StrictMVar m (Cached blk)))
-> (Cached blk -> Maybe String)
-> Cached blk
-> m (StrictMVar m (Cached blk))
forall a b. (a -> b) -> a -> b
$ \Cached blk
cached ->
        Word32 -> Cached blk -> Maybe String
forall blk. Word32 -> Cached blk -> Maybe String
checkInvariants Word32
pastChunksToCache Cached blk
cached
        Maybe String -> Maybe String -> Maybe String
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
        (ThunkInfo -> String
forall a. Show a => a -> String
show (ThunkInfo -> String) -> Maybe ThunkInfo -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cached blk -> Maybe ThunkInfo
forall a. NoThunks a => a -> Maybe ThunkInfo
unsafeNoThunks Cached blk
cached)

{------------------------------------------------------------------------------
  Background thread
------------------------------------------------------------------------------}

-- | Intended to run as a background thread.
--
-- Will expire past chunks that haven't been used for 'expireUnusedAfter' from
-- the cache.
expireUnusedChunks
  :: (HasCallStack, IOLike m)
  => CacheEnv m blk h
  -> m Void
expireUnusedChunks :: CacheEnv m blk h -> m Void
expireUnusedChunks CacheEnv { StrictMVar m (Cached blk)
cacheVar :: StrictMVar m (Cached blk)
$sel:cacheVar:CacheEnv :: forall (m :: * -> *) blk h.
CacheEnv m blk h -> StrictMVar m (Cached blk)
cacheVar, CacheConfig
cacheConfig :: CacheConfig
$sel:cacheConfig:CacheEnv :: forall (m :: * -> *) blk h. CacheEnv m blk h -> CacheConfig
cacheConfig, Tracer m TraceCacheEvent
tracer :: Tracer m TraceCacheEvent
$sel:tracer:CacheEnv :: forall (m :: * -> *) blk h.
CacheEnv m blk h -> Tracer m TraceCacheEvent
tracer } =
    m () -> m Void
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m Void) -> m () -> m Void
forall a b. (a -> b) -> a -> b
$ do
      Time
now <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
      Maybe TraceCacheEvent
mbTraceMsg <- StrictMVar m (Cached blk)
-> (Cached blk -> (Cached blk, Maybe TraceCacheEvent))
-> m (Maybe TraceCacheEvent)
forall (m :: * -> *) a b.
(MonadSTM m, HasCallStack) =>
StrictMVar m a -> (a -> (a, b)) -> m b
updateMVar StrictMVar m (Cached blk)
cacheVar ((Cached blk -> (Cached blk, Maybe TraceCacheEvent))
 -> m (Maybe TraceCacheEvent))
-> (Cached blk -> (Cached blk, Maybe TraceCacheEvent))
-> m (Maybe TraceCacheEvent)
forall a b. (a -> b) -> a -> b
$ Time -> Cached blk -> (Cached blk, Maybe TraceCacheEvent)
forall blk.
Time -> Cached blk -> (Cached blk, Maybe TraceCacheEvent)
garbageCollect Time
now
      (TraceCacheEvent -> m ()) -> Maybe TraceCacheEvent -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Tracer m TraceCacheEvent -> TraceCacheEvent -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceCacheEvent
tracer) Maybe TraceCacheEvent
mbTraceMsg
      DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
expireUnusedAfter
  where
    CacheConfig { DiffTime
expireUnusedAfter :: DiffTime
$sel:expireUnusedAfter:CacheConfig :: CacheConfig -> DiffTime
expireUnusedAfter } = CacheConfig
cacheConfig

    -- | Remove the least recently used past chunk from 'Cached' /if/ it
    -- hasn't been used for 'expireUnusedAfter', otherwise the original
    -- 'Cached' is returned.
    --
    -- In case a 'TracePastChunksExpired' event should be traced, it is
    -- returned as a 'Just'.
    garbageCollect
      :: Time
      -> Cached blk
      -> (Cached blk, Maybe TraceCacheEvent)
    garbageCollect :: Time -> Cached blk -> (Cached blk, Maybe TraceCacheEvent)
garbageCollect Time
now cached :: Cached blk
cached@Cached { IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo :: IntPSQ LastUsed (PastChunkInfo blk)
$sel:pastChunksInfo:Cached :: forall blk. Cached blk -> IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo, Word32
nbPastChunks :: Word32
$sel:nbPastChunks:Cached :: forall blk. Cached blk -> Word32
nbPastChunks } =
        case [(Int, LastUsed, PastChunkInfo blk)]
expiredPastChunks of
          [] -> (Cached blk
cached,  Maybe TraceCacheEvent
forall a. Maybe a
Nothing)
          [(Int, LastUsed, PastChunkInfo blk)]
_  -> (Cached blk
cached', TraceCacheEvent -> Maybe TraceCacheEvent
forall a. a -> Maybe a
Just TraceCacheEvent
traceMsg)
      where
        -- Every past chunk last used before (or at) this time, must be
        -- expired.
        expiredLastUsedTime :: LastUsed
        expiredLastUsedTime :: LastUsed
expiredLastUsedTime = Time -> LastUsed
LastUsed (Time -> LastUsed) -> Time -> LastUsed
forall a b. (a -> b) -> a -> b
$
          DiffTime -> Time
Time (Time
now Time -> Time -> DiffTime
`diffTime` DiffTime -> Time
Time DiffTime
expireUnusedAfter)

        ([(Int, LastUsed, PastChunkInfo blk)]
expiredPastChunks, IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo') =
          LastUsed
-> IntPSQ LastUsed (PastChunkInfo blk)
-> ([(Int, LastUsed, PastChunkInfo blk)],
    IntPSQ LastUsed (PastChunkInfo blk))
forall p v. Ord p => p -> IntPSQ p v -> ([(Int, p, v)], IntPSQ p v)
PSQ.atMostView LastUsed
expiredLastUsedTime IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo

        nbPastChunks' :: Word32
nbPastChunks' = Word32
nbPastChunks Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([(Int, LastUsed, PastChunkInfo blk)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, LastUsed, PastChunkInfo blk)]
expiredPastChunks)

        cached' :: Cached blk
cached' = Cached blk
cached
          { $sel:pastChunksInfo:Cached :: IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo = IntPSQ LastUsed (PastChunkInfo blk)
pastChunksInfo'
          , $sel:nbPastChunks:Cached :: Word32
nbPastChunks   = Word32
nbPastChunks'
          }

        !traceMsg :: TraceCacheEvent
traceMsg = [ChunkNo] -> Word32 -> TraceCacheEvent
TracePastChunksExpired
          -- Force this list, otherwise the traced message holds onto to the
          -- past chunk indices.
          ([ChunkNo] -> [ChunkNo]
forall (t :: * -> *) a. Foldable t => t a -> t a
forceElemsToWHNF
            [ Int -> ChunkNo
chunkNoFromInt (Int -> ChunkNo) -> Int -> ChunkNo
forall a b. (a -> b) -> a -> b
$ Int
chunk
            | (Int
chunk, LastUsed
_, PastChunkInfo blk
_) <- [(Int, LastUsed, PastChunkInfo blk)]
expiredPastChunks
            ])
          Word32
nbPastChunks'

{------------------------------------------------------------------------------
  Reading indices
------------------------------------------------------------------------------}

readPrimaryIndex
  :: (HasCallStack, IOLike m, Typeable blk, StandardHash blk)
  => Proxy blk
  -> HasFS m h
  -> ChunkInfo
  -> ChunkNo
  -> m (PrimaryIndex, IsEBB)
     -- ^ The primary index and whether it starts with an EBB or not
readPrimaryIndex :: Proxy blk
-> HasFS m h -> ChunkInfo -> ChunkNo -> m (PrimaryIndex, IsEBB)
readPrimaryIndex Proxy blk
pb HasFS m h
hasFS ChunkInfo
chunkInfo ChunkNo
chunk = do
    PrimaryIndex
primaryIndex <- Proxy blk -> HasFS m h -> ChunkNo -> m PrimaryIndex
forall blk (m :: * -> *) h.
(HasCallStack, MonadThrow m, StandardHash blk, Typeable blk) =>
Proxy blk -> HasFS m h -> ChunkNo -> m PrimaryIndex
Primary.load Proxy blk
pb HasFS m h
hasFS ChunkNo
chunk
    let firstIsEBB :: IsEBB
firstIsEBB
          | PrimaryIndex -> RelativeSlot -> Bool
Primary.containsSlot PrimaryIndex
primaryIndex RelativeSlot
firstRelativeSlot
          , HasCallStack => PrimaryIndex -> RelativeSlot -> Bool
PrimaryIndex -> RelativeSlot -> Bool
Primary.isFilledSlot PrimaryIndex
primaryIndex RelativeSlot
firstRelativeSlot
          = RelativeSlot -> IsEBB
relativeSlotIsEBB RelativeSlot
firstRelativeSlot
          | Bool
otherwise
          = IsEBB
IsNotEBB
    (PrimaryIndex, IsEBB) -> m (PrimaryIndex, IsEBB)
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimaryIndex
primaryIndex, IsEBB
firstIsEBB)
  where
    firstRelativeSlot :: RelativeSlot
    firstRelativeSlot :: RelativeSlot
firstRelativeSlot = ChunkInfo -> ChunkNo -> RelativeSlot
firstBlockOrEBB ChunkInfo
chunkInfo ChunkNo
chunk

readSecondaryIndex
  :: ( HasCallStack
     , ConvertRawHash blk
     , IOLike m
     , StandardHash blk
     , Typeable blk
     )
  => HasFS m h
  -> ChunkNo
  -> IsEBB
  -> m [Entry blk]
readSecondaryIndex :: HasFS m h -> ChunkNo -> IsEBB -> m [Entry blk]
readSecondaryIndex hasFS :: HasFS m h
hasFS@HasFS { HasCallStack => Handle h -> m Word64
hGetSize :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m Word64
hGetSize :: HasCallStack => Handle h -> m Word64
hGetSize } ChunkNo
chunk IsEBB
firstIsEBB = do
    !Word64
chunkFileSize <- HasFS m h
-> FsPath -> OpenMode -> (Handle h -> m Word64) -> m Word64
forall (m :: * -> *) h a.
(HasCallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS m h
hasFS FsPath
chunkFile OpenMode
ReadMode HasCallStack => Handle h -> m Word64
Handle h -> m Word64
hGetSize
    HasFS m h
-> Word32
-> ChunkNo
-> (Entry blk -> Bool)
-> Word64
-> IsEBB
-> m [Entry blk]
forall (m :: * -> *) blk h.
(HasCallStack, ConvertRawHash blk, MonadThrow m, StandardHash blk,
 Typeable blk) =>
HasFS m h
-> Word32
-> ChunkNo
-> (Entry blk -> Bool)
-> Word64
-> IsEBB
-> m [WithBlockSize (Entry blk)]
Secondary.readAllEntries HasFS m h
hasFS Word32
secondaryOffset
      ChunkNo
chunk Entry blk -> Bool
forall b. b -> Bool
stopCondition Word64
chunkFileSize IsEBB
firstIsEBB
  where
    chunkFile :: FsPath
chunkFile = ChunkNo -> FsPath
fsPathChunkFile ChunkNo
chunk
    -- Read from the start
    secondaryOffset :: Word32
secondaryOffset = Word32
0
    -- Don't stop until the end
    stopCondition :: b -> Bool
stopCondition = Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
False

loadCurrentChunkInfo
  :: forall m h blk.
     ( HasCallStack
     , ConvertRawHash blk
     , IOLike m
     , StandardHash blk
     , Typeable blk
     )
  => HasFS m h
  -> ChunkInfo
  -> ChunkNo
  -> m (CurrentChunkInfo blk)
loadCurrentChunkInfo :: HasFS m h -> ChunkInfo -> ChunkNo -> m (CurrentChunkInfo blk)
loadCurrentChunkInfo HasFS m h
hasFS ChunkInfo
chunkInfo ChunkNo
chunk = do
    -- We're assuming that when the primary index file exists, the secondary
    -- index file will also exist
    Bool
chunkExists <- HasFS m h -> FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesFileExist HasFS m h
hasFS FsPath
primaryIndexFile
    if Bool
chunkExists then do
      (PrimaryIndex
primaryIndex, IsEBB
firstIsEBB) <-
        Proxy blk
-> HasFS m h -> ChunkInfo -> ChunkNo -> m (PrimaryIndex, IsEBB)
forall (m :: * -> *) blk h.
(HasCallStack, IOLike m, Typeable blk, StandardHash blk) =>
Proxy blk
-> HasFS m h -> ChunkInfo -> ChunkNo -> m (PrimaryIndex, IsEBB)
readPrimaryIndex (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk) HasFS m h
hasFS ChunkInfo
chunkInfo ChunkNo
chunk
      [Entry blk]
entries <- HasFS m h -> ChunkNo -> IsEBB -> m [Entry blk]
forall blk (m :: * -> *) h.
(HasCallStack, ConvertRawHash blk, IOLike m, StandardHash blk,
 Typeable blk) =>
HasFS m h -> ChunkNo -> IsEBB -> m [Entry blk]
readSecondaryIndex HasFS m h
hasFS ChunkNo
chunk IsEBB
firstIsEBB
      CurrentChunkInfo blk -> m (CurrentChunkInfo blk)
forall (m :: * -> *) a. Monad m => a -> m a
return CurrentChunkInfo :: forall blk.
ChunkNo
-> StrictSeq Word32
-> StrictSeq (Entry blk)
-> CurrentChunkInfo blk
CurrentChunkInfo
        { $sel:currentChunkNo:CurrentChunkInfo :: ChunkNo
currentChunkNo      = ChunkNo
chunk
        , $sel:currentChunkOffsets:CurrentChunkInfo :: StrictSeq Word32
currentChunkOffsets =
          -- TODO optimise this
            [Word32] -> StrictSeq Word32
forall a. [a] -> StrictSeq a
Seq.fromList ([Word32] -> StrictSeq Word32)
-> (PrimaryIndex -> [Word32]) -> PrimaryIndex -> StrictSeq Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimaryIndex -> [Word32]
Primary.toSecondaryOffsets (PrimaryIndex -> StrictSeq Word32)
-> PrimaryIndex -> StrictSeq Word32
forall a b. (a -> b) -> a -> b
$ PrimaryIndex
primaryIndex
        , $sel:currentChunkEntries:CurrentChunkInfo :: StrictSeq (Entry blk)
currentChunkEntries = [Entry blk] -> StrictSeq (Entry blk)
forall a. [a] -> StrictSeq a
Seq.fromList [Entry blk]
entries
        }
    else
      CurrentChunkInfo blk -> m (CurrentChunkInfo blk)
forall (m :: * -> *) a. Monad m => a -> m a
return (CurrentChunkInfo blk -> m (CurrentChunkInfo blk))
-> CurrentChunkInfo blk -> m (CurrentChunkInfo blk)
forall a b. (a -> b) -> a -> b
$ ChunkNo -> CurrentChunkInfo blk
forall blk. ChunkNo -> CurrentChunkInfo blk
emptyCurrentChunkInfo ChunkNo
chunk
  where
    primaryIndexFile :: FsPath
primaryIndexFile = ChunkNo -> FsPath
fsPathPrimaryIndexFile ChunkNo
chunk

loadPastChunkInfo
  :: forall blk m h.
     ( HasCallStack
     , ConvertRawHash blk
     , IOLike m
     , StandardHash blk
     , Typeable blk
     )
  => HasFS m h
  -> ChunkInfo
  -> ChunkNo
  -> m (PastChunkInfo blk)
loadPastChunkInfo :: HasFS m h -> ChunkInfo -> ChunkNo -> m (PastChunkInfo blk)
loadPastChunkInfo HasFS m h
hasFS ChunkInfo
chunkInfo ChunkNo
chunk = do
    (PrimaryIndex
primaryIndex, IsEBB
firstIsEBB) <- Proxy blk
-> HasFS m h -> ChunkInfo -> ChunkNo -> m (PrimaryIndex, IsEBB)
forall (m :: * -> *) blk h.
(HasCallStack, IOLike m, Typeable blk, StandardHash blk) =>
Proxy blk
-> HasFS m h -> ChunkInfo -> ChunkNo -> m (PrimaryIndex, IsEBB)
readPrimaryIndex (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk) HasFS m h
hasFS ChunkInfo
chunkInfo ChunkNo
chunk
    [Entry blk]
entries <- HasFS m h -> ChunkNo -> IsEBB -> m [Entry blk]
forall blk (m :: * -> *) h.
(HasCallStack, ConvertRawHash blk, IOLike m, StandardHash blk,
 Typeable blk) =>
HasFS m h -> ChunkNo -> IsEBB -> m [Entry blk]
readSecondaryIndex HasFS m h
hasFS ChunkNo
chunk IsEBB
firstIsEBB
    PastChunkInfo blk -> m (PastChunkInfo blk)
forall (m :: * -> *) a. Monad m => a -> m a
return PastChunkInfo :: forall blk. PrimaryIndex -> Vector (Entry blk) -> PastChunkInfo blk
PastChunkInfo
      { $sel:pastChunkOffsets:PastChunkInfo :: PrimaryIndex
pastChunkOffsets = PrimaryIndex
primaryIndex
      , $sel:pastChunkEntries:PastChunkInfo :: Vector (Entry blk)
pastChunkEntries = [Entry blk] -> Vector (Entry blk)
forall a. [a] -> Vector a
Vector.fromList ([Entry blk] -> Vector (Entry blk))
-> [Entry blk] -> Vector (Entry blk)
forall a b. (a -> b) -> a -> b
$ [Entry blk] -> [Entry blk]
forall (t :: * -> *) a. Foldable t => t a -> t a
forceElemsToWHNF [Entry blk]
entries
      }

getChunkInfo
  :: forall m blk h.
     ( HasCallStack
     , ConvertRawHash blk
     , IOLike m
     , StandardHash blk
     , Typeable blk
     )
  => CacheEnv m blk h
  -> ChunkNo
  -> m (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
getChunkInfo :: CacheEnv m blk h
-> ChunkNo -> m (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
getChunkInfo CacheEnv m blk h
cacheEnv ChunkNo
chunk = do
    LastUsed
lastUsed <- Time -> LastUsed
LastUsed (Time -> LastUsed) -> m Time -> m LastUsed
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
    -- Make sure we don't leave an empty MVar in case of an exception.
    Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
mbCacheHit <- m (Cached blk)
-> (Cached blk -> m Bool)
-> (Cached blk
    -> m (Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk))))
-> m (Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk)))
forall (m :: * -> *) a b c.
MonadCatch m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError (StrictMVar m (Cached blk) -> m (Cached blk)
forall (m :: * -> *) a. MonadSTM m => StrictMVar m a -> m a
takeMVar StrictMVar m (Cached blk)
cacheVar) (StrictMVar m (Cached blk) -> Cached blk -> m Bool
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictMVar m a -> a -> m Bool
tryPutMVar StrictMVar m (Cached blk)
cacheVar) ((Cached blk
  -> m (Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk))))
 -> m (Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk))))
-> (Cached blk
    -> m (Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk))))
-> m (Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk)))
forall a b. (a -> b) -> a -> b
$
      \cached :: Cached blk
cached@Cached { ChunkNo
currentChunk :: ChunkNo
$sel:currentChunk:Cached :: forall blk. Cached blk -> ChunkNo
currentChunk, CurrentChunkInfo blk
currentChunkInfo :: CurrentChunkInfo blk
$sel:currentChunkInfo:Cached :: forall blk. Cached blk -> CurrentChunkInfo blk
currentChunkInfo, Word32
nbPastChunks :: Word32
$sel:nbPastChunks:Cached :: forall blk. Cached blk -> Word32
nbPastChunks } -> if
        | ChunkNo
chunk ChunkNo -> ChunkNo -> Bool
forall a. Eq a => a -> a -> Bool
== ChunkNo
currentChunk -> do
          -- Cache hit for the current chunk
          StrictMVar m (Cached blk) -> Cached blk -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictMVar m a -> a -> m ()
putMVar StrictMVar m (Cached blk)
cacheVar Cached blk
cached
          Tracer m TraceCacheEvent -> TraceCacheEvent -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceCacheEvent
tracer (TraceCacheEvent -> m ()) -> TraceCacheEvent -> m ()
forall a b. (a -> b) -> a -> b
$ ChunkNo -> Word32 -> TraceCacheEvent
TraceCurrentChunkHit ChunkNo
chunk Word32
nbPastChunks
          Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
-> m (Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
 -> m (Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk))))
-> Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
-> m (Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk)))
forall a b. (a -> b) -> a -> b
$ Either (CurrentChunkInfo blk) (PastChunkInfo blk)
-> Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
forall a. a -> Maybe a
Just (Either (CurrentChunkInfo blk) (PastChunkInfo blk)
 -> Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk)))
-> Either (CurrentChunkInfo blk) (PastChunkInfo blk)
-> Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
forall a b. (a -> b) -> a -> b
$ CurrentChunkInfo blk
-> Either (CurrentChunkInfo blk) (PastChunkInfo blk)
forall a b. a -> Either a b
Left CurrentChunkInfo blk
currentChunkInfo
        | Just (PastChunkInfo blk
pastChunkInfo, Cached blk
cached') <- ChunkNo
-> LastUsed -> Cached blk -> Maybe (PastChunkInfo blk, Cached blk)
forall blk.
ChunkNo
-> LastUsed -> Cached blk -> Maybe (PastChunkInfo blk, Cached blk)
lookupPastChunkInfo ChunkNo
chunk LastUsed
lastUsed Cached blk
cached -> do
          -- Cache hit for an chunk in the past
          StrictMVar m (Cached blk) -> Cached blk -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictMVar m a -> a -> m ()
putMVar StrictMVar m (Cached blk)
cacheVar Cached blk
cached'
          Tracer m TraceCacheEvent -> TraceCacheEvent -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceCacheEvent
tracer (TraceCacheEvent -> m ()) -> TraceCacheEvent -> m ()
forall a b. (a -> b) -> a -> b
$ ChunkNo -> Word32 -> TraceCacheEvent
TracePastChunkHit ChunkNo
chunk Word32
nbPastChunks
          Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
-> m (Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
 -> m (Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk))))
-> Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
-> m (Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk)))
forall a b. (a -> b) -> a -> b
$ Either (CurrentChunkInfo blk) (PastChunkInfo blk)
-> Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
forall a. a -> Maybe a
Just (Either (CurrentChunkInfo blk) (PastChunkInfo blk)
 -> Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk)))
-> Either (CurrentChunkInfo blk) (PastChunkInfo blk)
-> Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
forall a b. (a -> b) -> a -> b
$ PastChunkInfo blk
-> Either (CurrentChunkInfo blk) (PastChunkInfo blk)
forall a b. b -> Either a b
Right PastChunkInfo blk
pastChunkInfo
        | Bool
otherwise -> do
          -- Cache miss for an chunk in the past. We don't want to hold on to
          -- the 'cacheVar' MVar, blocking all other access to the cace, while
          -- we're reading things from disk, so put it back now and update the
          -- cache afterwards.
          StrictMVar m (Cached blk) -> Cached blk -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictMVar m a -> a -> m ()
putMVar StrictMVar m (Cached blk)
cacheVar Cached blk
cached
          Tracer m TraceCacheEvent -> TraceCacheEvent -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceCacheEvent
tracer (TraceCacheEvent -> m ()) -> TraceCacheEvent -> m ()
forall a b. (a -> b) -> a -> b
$ ChunkNo -> Word32 -> TraceCacheEvent
TracePastChunkMiss ChunkNo
chunk Word32
nbPastChunks
          Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
-> m (Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
forall a. Maybe a
Nothing
    case Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
mbCacheHit of
      Just Either (CurrentChunkInfo blk) (PastChunkInfo blk)
hit -> Either (CurrentChunkInfo blk) (PastChunkInfo blk)
-> m (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
forall (m :: * -> *) a. Monad m => a -> m a
return Either (CurrentChunkInfo blk) (PastChunkInfo blk)
hit
      Maybe (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
Nothing  -> do
        -- Cache miss, load both entire indices for the chunk from disk.
        PastChunkInfo blk
pastChunkInfo <- HasFS m h -> ChunkInfo -> ChunkNo -> m (PastChunkInfo blk)
forall blk (m :: * -> *) h.
(HasCallStack, ConvertRawHash blk, IOLike m, StandardHash blk,
 Typeable blk) =>
HasFS m h -> ChunkInfo -> ChunkNo -> m (PastChunkInfo blk)
loadPastChunkInfo HasFS m h
hasFS ChunkInfo
chunkInfo ChunkNo
chunk
        -- Loading the chunk might have taken some time, so obtain the time
        -- again.
        LastUsed
lastUsed' <- Time -> LastUsed
LastUsed (Time -> LastUsed) -> m Time -> m LastUsed
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
        Maybe ChunkNo
mbEvicted <- StrictMVar m (Cached blk)
-> (Cached blk -> (Cached blk, Maybe ChunkNo)) -> m (Maybe ChunkNo)
forall (m :: * -> *) a b.
(MonadSTM m, HasCallStack) =>
StrictMVar m a -> (a -> (a, b)) -> m b
updateMVar StrictMVar m (Cached blk)
cacheVar ((Cached blk -> (Cached blk, Maybe ChunkNo)) -> m (Maybe ChunkNo))
-> (Cached blk -> (Cached blk, Maybe ChunkNo)) -> m (Maybe ChunkNo)
forall a b. (a -> b) -> a -> b
$
          Word32 -> Cached blk -> (Cached blk, Maybe ChunkNo)
forall blk. Word32 -> Cached blk -> (Cached blk, Maybe ChunkNo)
evictIfNecessary Word32
pastChunksToCache (Cached blk -> (Cached blk, Maybe ChunkNo))
-> (Cached blk -> Cached blk)
-> Cached blk
-> (Cached blk, Maybe ChunkNo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          ChunkNo
-> LastUsed -> PastChunkInfo blk -> Cached blk -> Cached blk
forall blk.
ChunkNo
-> LastUsed -> PastChunkInfo blk -> Cached blk -> Cached blk
addPastChunkInfo ChunkNo
chunk LastUsed
lastUsed' PastChunkInfo blk
pastChunkInfo
        Maybe ChunkNo -> (ChunkNo -> m ()) -> m ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe ChunkNo
mbEvicted ((ChunkNo -> m ()) -> m ()) -> (ChunkNo -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \ChunkNo
evicted ->
          -- If we had to evict, we are at 'pastChunksToCache'
          Tracer m TraceCacheEvent -> TraceCacheEvent -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceCacheEvent
tracer (TraceCacheEvent -> m ()) -> TraceCacheEvent -> m ()
forall a b. (a -> b) -> a -> b
$ ChunkNo -> Word32 -> TraceCacheEvent
TracePastChunkEvict ChunkNo
evicted Word32
pastChunksToCache
        Either (CurrentChunkInfo blk) (PastChunkInfo blk)
-> m (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (CurrentChunkInfo blk) (PastChunkInfo blk)
 -> m (Either (CurrentChunkInfo blk) (PastChunkInfo blk)))
-> Either (CurrentChunkInfo blk) (PastChunkInfo blk)
-> m (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
forall a b. (a -> b) -> a -> b
$ PastChunkInfo blk
-> Either (CurrentChunkInfo blk) (PastChunkInfo blk)
forall a b. b -> Either a b
Right PastChunkInfo blk
pastChunkInfo
  where
    CacheEnv { HasFS m h
hasFS :: HasFS m h
$sel:hasFS:CacheEnv :: forall (m :: * -> *) blk h. CacheEnv m blk h -> HasFS m h
hasFS, StrictMVar m (Cached blk)
cacheVar :: StrictMVar m (Cached blk)
$sel:cacheVar:CacheEnv :: forall (m :: * -> *) blk h.
CacheEnv m blk h -> StrictMVar m (Cached blk)
cacheVar, CacheConfig
cacheConfig :: CacheConfig
$sel:cacheConfig:CacheEnv :: forall (m :: * -> *) blk h. CacheEnv m blk h -> CacheConfig
cacheConfig, Tracer m TraceCacheEvent
tracer :: Tracer m TraceCacheEvent
$sel:tracer:CacheEnv :: forall (m :: * -> *) blk h.
CacheEnv m blk h -> Tracer m TraceCacheEvent
tracer, ChunkInfo
chunkInfo :: ChunkInfo
$sel:chunkInfo:CacheEnv :: forall (m :: * -> *) blk h. CacheEnv m blk h -> ChunkInfo
chunkInfo } = CacheEnv m blk h
cacheEnv
    CacheConfig { Word32
pastChunksToCache :: Word32
$sel:pastChunksToCache:CacheConfig :: CacheConfig -> Word32
pastChunksToCache } = CacheConfig
cacheConfig

{------------------------------------------------------------------------------
  Operations
------------------------------------------------------------------------------}

-- | Stops the background expiration thread.
--
-- This operation is idempotent.
close :: IOLike m => CacheEnv m blk h -> m ()
close :: CacheEnv m blk h -> m ()
close CacheEnv { StrictMVar m (Maybe (Thread m Void))
bgThreadVar :: StrictMVar m (Maybe (Thread m Void))
$sel:bgThreadVar:CacheEnv :: forall (m :: * -> *) blk h.
CacheEnv m blk h -> StrictMVar m (Maybe (Thread m Void))
bgThreadVar } =
    m () -> m ()
forall (m :: * -> *) a. MonadMask m => m a -> m a
mask_ (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictMVar m (Maybe (Thread m Void))
-> (Maybe (Thread m Void) -> m (Maybe (Thread m Void))) -> m ()
forall (m :: * -> *) a.
(MonadSTM m, MonadCatch m, HasCallStack) =>
StrictMVar m a -> (a -> m a) -> m ()
modifyMVar_ StrictMVar m (Maybe (Thread m Void))
bgThreadVar ((Maybe (Thread m Void) -> m (Maybe (Thread m Void))) -> m ())
-> (Maybe (Thread m Void) -> m (Maybe (Thread m Void))) -> m ()
forall a b. (a -> b) -> a -> b
$ \Maybe (Thread m Void)
mbBgThread -> do
      (Thread m Void -> m ()) -> Maybe (Thread m Void) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Thread m Void -> m ()
forall (m :: * -> *) a. IOLike m => Thread m a -> m ()
cancelThread Maybe (Thread m Void)
mbBgThread
      Maybe (Thread m Void) -> m (Maybe (Thread m Void))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Thread m Void)
forall a. Maybe a
Nothing

-- | Restarts the background expiration thread, drops all previously cached
-- information, loads the given chunk.
--
-- PRECONDITION: the background thread expiring unused past chunks must have
-- been terminated.
restart
  :: (ConvertRawHash blk, IOLike m, StandardHash blk, Typeable blk)
  => CacheEnv m blk h
  -> ChunkNo  -- ^ The new current chunk
  -> m ()
restart :: CacheEnv m blk h -> ChunkNo -> m ()
restart CacheEnv m blk h
cacheEnv ChunkNo
chunk = do
    CurrentChunkInfo blk
currentChunkInfo <- HasFS m h -> ChunkInfo -> ChunkNo -> m (CurrentChunkInfo blk)
forall (m :: * -> *) h blk.
(HasCallStack, ConvertRawHash blk, IOLike m, StandardHash blk,
 Typeable blk) =>
HasFS m h -> ChunkInfo -> ChunkNo -> m (CurrentChunkInfo blk)
loadCurrentChunkInfo HasFS m h
hasFS ChunkInfo
chunkInfo ChunkNo
chunk
    m (Cached blk) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Cached blk) -> m ()) -> m (Cached blk) -> m ()
forall a b. (a -> b) -> a -> b
$ StrictMVar m (Cached blk) -> Cached blk -> m (Cached blk)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictMVar m a -> a -> m a
swapMVar StrictMVar m (Cached blk)
cacheVar (Cached blk -> m (Cached blk)) -> Cached blk -> m (Cached blk)
forall a b. (a -> b) -> a -> b
$ ChunkNo -> CurrentChunkInfo blk -> Cached blk
forall blk. ChunkNo -> CurrentChunkInfo blk -> Cached blk
emptyCached ChunkNo
chunk CurrentChunkInfo blk
currentChunkInfo
    m () -> m ()
forall (m :: * -> *) a. MonadMask m => m a -> m a
mask_ (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictMVar m (Maybe (Thread m Void))
-> (Maybe (Thread m Void) -> m (Maybe (Thread m Void))) -> m ()
forall (m :: * -> *) a.
(MonadSTM m, MonadCatch m, HasCallStack) =>
StrictMVar m a -> (a -> m a) -> m ()
modifyMVar_ StrictMVar m (Maybe (Thread m Void))
bgThreadVar ((Maybe (Thread m Void) -> m (Maybe (Thread m Void))) -> m ())
-> (Maybe (Thread m Void) -> m (Maybe (Thread m Void))) -> m ()
forall a b. (a -> b) -> a -> b
$ \Maybe (Thread m Void)
mbBgThread ->
      case Maybe (Thread m Void)
mbBgThread of
        Just Thread m Void
_  -> IOError -> m (Maybe (Thread m Void))
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (IOError -> m (Maybe (Thread m Void)))
-> IOError -> m (Maybe (Thread m Void))
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"background thread still running"
        Maybe (Thread m Void)
Nothing -> do
          !Thread m Void
bgThread <- ResourceRegistry m -> String -> m Void -> m (Thread m Void)
forall (m :: * -> *) a.
(IOLike m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry String
"ImmutableDB.expireUnusedChunks" (m Void -> m (Thread m Void)) -> m Void -> m (Thread m Void)
forall a b. (a -> b) -> a -> b
$
            CacheEnv m blk h -> m Void
forall (m :: * -> *) blk h.
(HasCallStack, IOLike m) =>
CacheEnv m blk h -> m Void
expireUnusedChunks CacheEnv m blk h
cacheEnv
          Maybe (Thread m Void) -> m (Maybe (Thread m Void))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Thread m Void) -> m (Maybe (Thread m Void)))
-> Maybe (Thread m Void) -> m (Maybe (Thread m Void))
forall a b. (a -> b) -> a -> b
$ Thread m Void -> Maybe (Thread m Void)
forall a. a -> Maybe a
Just Thread m Void
bgThread
  where
    CacheEnv { HasFS m h
hasFS :: HasFS m h
$sel:hasFS:CacheEnv :: forall (m :: * -> *) blk h. CacheEnv m blk h -> HasFS m h
hasFS, ResourceRegistry m
registry :: ResourceRegistry m
$sel:registry:CacheEnv :: forall (m :: * -> *) blk h. CacheEnv m blk h -> ResourceRegistry m
registry, StrictMVar m (Cached blk)
cacheVar :: StrictMVar m (Cached blk)
$sel:cacheVar:CacheEnv :: forall (m :: * -> *) blk h.
CacheEnv m blk h -> StrictMVar m (Cached blk)
cacheVar, StrictMVar m (Maybe (Thread m Void))
bgThreadVar :: StrictMVar m (Maybe (Thread m Void))
$sel:bgThreadVar:CacheEnv :: forall (m :: * -> *) blk h.
CacheEnv m blk h -> StrictMVar m (Maybe (Thread m Void))
bgThreadVar, ChunkInfo
chunkInfo :: ChunkInfo
$sel:chunkInfo:CacheEnv :: forall (m :: * -> *) blk h. CacheEnv m blk h -> ChunkInfo
chunkInfo } = CacheEnv m blk h
cacheEnv

{------------------------------------------------------------------------------
  On the primary index
------------------------------------------------------------------------------}

readOffsets
  :: ( HasCallStack
     , ConvertRawHash blk
     , IOLike m
     , StandardHash blk
     , Typeable blk
     , Traversable t
     )
  => CacheEnv m blk h
  -> ChunkNo
  -> t RelativeSlot
  -> m (t (Maybe SecondaryOffset))
readOffsets :: CacheEnv m blk h
-> ChunkNo -> t RelativeSlot -> m (t (Maybe Word32))
readOffsets CacheEnv m blk h
cacheEnv ChunkNo
chunk t RelativeSlot
relSlots =
    CacheEnv m blk h
-> ChunkNo -> m (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
forall (m :: * -> *) blk h.
(HasCallStack, ConvertRawHash blk, IOLike m, StandardHash blk,
 Typeable blk) =>
CacheEnv m blk h
-> ChunkNo -> m (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
getChunkInfo CacheEnv m blk h
cacheEnv ChunkNo
chunk m (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
-> (Either (CurrentChunkInfo blk) (PastChunkInfo blk)
    -> t (Maybe Word32))
-> m (t (Maybe Word32))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
      Left CurrentChunkInfo { StrictSeq Word32
currentChunkOffsets :: StrictSeq Word32
$sel:currentChunkOffsets:CurrentChunkInfo :: forall blk. CurrentChunkInfo blk -> StrictSeq Word32
currentChunkOffsets } ->
        StrictSeq Word32 -> RelativeSlot -> Maybe Word32
getOffsetFromSecondaryOffsets StrictSeq Word32
currentChunkOffsets (RelativeSlot -> Maybe Word32)
-> t RelativeSlot -> t (Maybe Word32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t RelativeSlot
relSlots
      Right PastChunkInfo { PrimaryIndex
pastChunkOffsets :: PrimaryIndex
$sel:pastChunkOffsets:PastChunkInfo :: forall blk. PastChunkInfo blk -> PrimaryIndex
pastChunkOffsets } ->
        PrimaryIndex -> RelativeSlot -> Maybe Word32
getOffsetFromPrimaryIndex PrimaryIndex
pastChunkOffsets (RelativeSlot -> Maybe Word32)
-> t RelativeSlot -> t (Maybe Word32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t RelativeSlot
relSlots
  where
    getOffsetFromSecondaryOffsets
      :: StrictSeq SecondaryOffset
      -> RelativeSlot
      -> Maybe SecondaryOffset
    getOffsetFromSecondaryOffsets :: StrictSeq Word32 -> RelativeSlot -> Maybe Word32
getOffsetFromSecondaryOffsets StrictSeq Word32
offsets RelativeSlot
relSlot =
      let s :: Word64
s = HasCallStack => ChunkNo -> RelativeSlot -> Word64
ChunkNo -> RelativeSlot -> Word64
assertRelativeSlotInChunk ChunkNo
chunk RelativeSlot
relSlot in
      case Int -> StrictSeq Word32 -> (StrictSeq Word32, StrictSeq Word32)
forall a. Int -> StrictSeq a -> (StrictSeq a, StrictSeq a)
Seq.splitAt (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) StrictSeq Word32
offsets of
        (StrictSeq Word32
_ Seq.:|> Word32
offset, Word32
offsetAfter Seq.:<| StrictSeq Word32
_)
          | Word32
offset Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
offsetAfter
            -- The slot is not empty
          -> Word32 -> Maybe Word32
forall a. a -> Maybe a
Just Word32
offset
        (StrictSeq Word32, StrictSeq Word32)
_ -> Maybe Word32
forall a. Maybe a
Nothing

    getOffsetFromPrimaryIndex
      :: PrimaryIndex
      -> RelativeSlot
      -> Maybe SecondaryOffset
    getOffsetFromPrimaryIndex :: PrimaryIndex -> RelativeSlot -> Maybe Word32
getOffsetFromPrimaryIndex PrimaryIndex
index RelativeSlot
relSlot
      | PrimaryIndex -> RelativeSlot -> Bool
Primary.containsSlot  PrimaryIndex
index RelativeSlot
relSlot
      , HasCallStack => PrimaryIndex -> RelativeSlot -> Bool
PrimaryIndex -> RelativeSlot -> Bool
Primary.isFilledSlot  PrimaryIndex
index RelativeSlot
relSlot
      = Word32 -> Maybe Word32
forall a. a -> Maybe a
Just (Word32 -> Maybe Word32) -> Word32 -> Maybe Word32
forall a b. (a -> b) -> a -> b
$ HasCallStack => PrimaryIndex -> RelativeSlot -> Word32
PrimaryIndex -> RelativeSlot -> Word32
Primary.offsetOfSlot PrimaryIndex
index RelativeSlot
relSlot
      | Bool
otherwise
      = Maybe Word32
forall a. Maybe a
Nothing

readFirstFilledSlot
  :: ( HasCallStack
     , ConvertRawHash blk
     , IOLike m
     , StandardHash blk
     , Typeable blk
     )
  => CacheEnv m blk h
  -> ChunkNo
  -> m (Maybe RelativeSlot)
readFirstFilledSlot :: CacheEnv m blk h -> ChunkNo -> m (Maybe RelativeSlot)
readFirstFilledSlot CacheEnv m blk h
cacheEnv ChunkNo
chunk =
    CacheEnv m blk h
-> ChunkNo -> m (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
forall (m :: * -> *) blk h.
(HasCallStack, ConvertRawHash blk, IOLike m, StandardHash blk,
 Typeable blk) =>
CacheEnv m blk h
-> ChunkNo -> m (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
getChunkInfo CacheEnv m blk h
cacheEnv ChunkNo
chunk m (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
-> (Either (CurrentChunkInfo blk) (PastChunkInfo blk)
    -> Maybe RelativeSlot)
-> m (Maybe RelativeSlot)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
      Left CurrentChunkInfo { StrictSeq Word32
currentChunkOffsets :: StrictSeq Word32
$sel:currentChunkOffsets:CurrentChunkInfo :: forall blk. CurrentChunkInfo blk -> StrictSeq Word32
currentChunkOffsets } ->
        StrictSeq Word32 -> Maybe RelativeSlot
firstFilledSlotInSeq StrictSeq Word32
currentChunkOffsets
      Right PastChunkInfo { PrimaryIndex
pastChunkOffsets :: PrimaryIndex
$sel:pastChunkOffsets:PastChunkInfo :: forall blk. PastChunkInfo blk -> PrimaryIndex
pastChunkOffsets } ->
        ChunkInfo -> PrimaryIndex -> Maybe RelativeSlot
Primary.firstFilledSlot ChunkInfo
chunkInfo PrimaryIndex
pastChunkOffsets
  where
    CacheEnv { ChunkInfo
chunkInfo :: ChunkInfo
$sel:chunkInfo:CacheEnv :: forall (m :: * -> *) blk h. CacheEnv m blk h -> ChunkInfo
chunkInfo } = CacheEnv m blk h
cacheEnv

    firstFilledSlotInSeq :: StrictSeq SecondaryOffset -> Maybe RelativeSlot
    firstFilledSlotInSeq :: StrictSeq Word32 -> Maybe RelativeSlot
firstFilledSlotInSeq = (Int -> RelativeSlot) -> Maybe Int -> Maybe RelativeSlot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> RelativeSlot
indexToRelativeSlot (Maybe Int -> Maybe RelativeSlot)
-> (StrictSeq Word32 -> Maybe Int)
-> StrictSeq Word32
-> Maybe RelativeSlot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word32 -> Bool) -> StrictSeq Word32 -> Maybe Int
forall a. (a -> Bool) -> StrictSeq a -> Maybe Int
Seq.findIndexL (Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0)
      where
        indexToRelativeSlot :: Int -> RelativeSlot
        indexToRelativeSlot :: Int -> RelativeSlot
indexToRelativeSlot = HasCallStack => ChunkInfo -> ChunkNo -> Word64 -> RelativeSlot
ChunkInfo -> ChunkNo -> Word64 -> RelativeSlot
mkRelativeSlot ChunkInfo
chunkInfo ChunkNo
chunk (Word64 -> RelativeSlot) -> (Int -> Word64) -> Int -> RelativeSlot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> (Int -> Int) -> Int -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. Enum a => a -> a
pred

-- | This is called when a new chunk is started, which means we need to update
-- 'Cached' to reflect this.
openPrimaryIndex
  :: ( HasCallStack
     , ConvertRawHash blk
     , IOLike m
     , StandardHash blk
     , Typeable blk
     )
  => CacheEnv m blk h
  -> ChunkNo
  -> AllowExisting
  -> m (Handle h)
openPrimaryIndex :: CacheEnv m blk h -> ChunkNo -> AllowExisting -> m (Handle h)
openPrimaryIndex CacheEnv m blk h
cacheEnv ChunkNo
chunk AllowExisting
allowExisting = do
    LastUsed
lastUsed <- Time -> LastUsed
LastUsed (Time -> LastUsed) -> m Time -> m LastUsed
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
    Handle h
pHnd <- 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 ChunkNo
chunk AllowExisting
allowExisting
    -- Don't leak the handle in case of an exception
    (m (Handle h) -> m () -> m (Handle h))
-> m () -> m (Handle h) -> m (Handle h)
forall a b c. (a -> b -> c) -> b -> a -> c
flip m (Handle h) -> m () -> m (Handle h)
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
onException (HasCallStack => Handle h -> m ()
Handle h -> m ()
hClose Handle h
pHnd) (m (Handle h) -> m (Handle h)) -> m (Handle h) -> m (Handle h)
forall a b. (a -> b) -> a -> b
$ do
      CurrentChunkInfo blk
newCurrentChunkInfo <- case AllowExisting
allowExisting of
        AllowExisting
MustBeNew     -> CurrentChunkInfo blk -> m (CurrentChunkInfo blk)
forall (m :: * -> *) a. Monad m => a -> m a
return (CurrentChunkInfo blk -> m (CurrentChunkInfo blk))
-> CurrentChunkInfo blk -> m (CurrentChunkInfo blk)
forall a b. (a -> b) -> a -> b
$ ChunkNo -> CurrentChunkInfo blk
forall blk. ChunkNo -> CurrentChunkInfo blk
emptyCurrentChunkInfo ChunkNo
chunk
        AllowExisting
AllowExisting -> HasFS m h -> ChunkInfo -> ChunkNo -> m (CurrentChunkInfo blk)
forall (m :: * -> *) h blk.
(HasCallStack, ConvertRawHash blk, IOLike m, StandardHash blk,
 Typeable blk) =>
HasFS m h -> ChunkInfo -> ChunkNo -> m (CurrentChunkInfo blk)
loadCurrentChunkInfo HasFS m h
hasFS ChunkInfo
chunkInfo ChunkNo
chunk
      Maybe ChunkNo
mbEvicted <- StrictMVar m (Cached blk)
-> (Cached blk -> (Cached blk, Maybe ChunkNo)) -> m (Maybe ChunkNo)
forall (m :: * -> *) a b.
(MonadSTM m, HasCallStack) =>
StrictMVar m a -> (a -> (a, b)) -> m b
updateMVar StrictMVar m (Cached blk)
cacheVar ((Cached blk -> (Cached blk, Maybe ChunkNo)) -> m (Maybe ChunkNo))
-> (Cached blk -> (Cached blk, Maybe ChunkNo)) -> m (Maybe ChunkNo)
forall a b. (a -> b) -> a -> b
$
        Word32 -> Cached blk -> (Cached blk, Maybe ChunkNo)
forall blk. Word32 -> Cached blk -> (Cached blk, Maybe ChunkNo)
evictIfNecessary Word32
pastChunksToCache (Cached blk -> (Cached blk, Maybe ChunkNo))
-> (Cached blk -> Cached blk)
-> Cached blk
-> (Cached blk, Maybe ChunkNo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        ChunkNo
-> LastUsed -> CurrentChunkInfo blk -> Cached blk -> Cached blk
forall blk.
ChunkNo
-> LastUsed -> CurrentChunkInfo blk -> Cached blk -> Cached blk
openChunk ChunkNo
chunk LastUsed
lastUsed CurrentChunkInfo blk
newCurrentChunkInfo
      Maybe ChunkNo -> (ChunkNo -> m ()) -> m ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe ChunkNo
mbEvicted ((ChunkNo -> m ()) -> m ()) -> (ChunkNo -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \ChunkNo
evicted ->
        -- If we had to evict, we are at 'pastChunksToCache'
        Tracer m TraceCacheEvent -> TraceCacheEvent -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceCacheEvent
tracer (TraceCacheEvent -> m ()) -> TraceCacheEvent -> m ()
forall a b. (a -> b) -> a -> b
$ ChunkNo -> Word32 -> TraceCacheEvent
TracePastChunkEvict ChunkNo
evicted Word32
pastChunksToCache
      Handle h -> m (Handle h)
forall (m :: * -> *) a. Monad m => a -> m a
return Handle h
pHnd
  where
    CacheEnv { HasFS m h
hasFS :: HasFS m h
$sel:hasFS:CacheEnv :: forall (m :: * -> *) blk h. CacheEnv m blk h -> HasFS m h
hasFS, StrictMVar m (Cached blk)
cacheVar :: StrictMVar m (Cached blk)
$sel:cacheVar:CacheEnv :: forall (m :: * -> *) blk h.
CacheEnv m blk h -> StrictMVar m (Cached blk)
cacheVar, CacheConfig
cacheConfig :: CacheConfig
$sel:cacheConfig:CacheEnv :: forall (m :: * -> *) blk h. CacheEnv m blk h -> CacheConfig
cacheConfig, Tracer m TraceCacheEvent
tracer :: Tracer m TraceCacheEvent
$sel:tracer:CacheEnv :: forall (m :: * -> *) blk h.
CacheEnv m blk h -> Tracer m TraceCacheEvent
tracer, ChunkInfo
chunkInfo :: ChunkInfo
$sel:chunkInfo:CacheEnv :: forall (m :: * -> *) blk h. CacheEnv m blk h -> ChunkInfo
chunkInfo } = CacheEnv m blk h
cacheEnv
    HasFS { HasCallStack => Handle h -> m ()
hClose :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m ()
hClose :: HasCallStack => Handle h -> m ()
hClose } = HasFS m h
hasFS
    CacheConfig { Word32
pastChunksToCache :: Word32
$sel:pastChunksToCache:CacheConfig :: CacheConfig -> Word32
pastChunksToCache } = CacheConfig
cacheConfig

appendOffsets
  :: (HasCallStack, Foldable f, IOLike m)
  => CacheEnv m blk h
  -> Handle h
  -> f SecondaryOffset
  -> m ()
appendOffsets :: CacheEnv m blk h -> Handle h -> f Word32 -> m ()
appendOffsets CacheEnv { HasFS m h
hasFS :: HasFS m h
$sel:hasFS:CacheEnv :: forall (m :: * -> *) blk h. CacheEnv m blk h -> HasFS m h
hasFS, StrictMVar m (Cached blk)
cacheVar :: StrictMVar m (Cached blk)
$sel:cacheVar:CacheEnv :: forall (m :: * -> *) blk h.
CacheEnv m blk h -> StrictMVar m (Cached blk)
cacheVar } Handle h
pHnd f Word32
offsets = do
    HasFS m h -> Handle h -> f Word32 -> m ()
forall (m :: * -> *) (f :: * -> *) h.
(Monad m, Foldable f, HasCallStack) =>
HasFS m h -> Handle h -> f Word32 -> m ()
Primary.appendOffsets HasFS m h
hasFS Handle h
pHnd f Word32
offsets
    StrictMVar m (Cached blk) -> (Cached blk -> Cached blk) -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictMVar m a -> (a -> a) -> m ()
updateMVar_ StrictMVar m (Cached blk)
cacheVar Cached blk -> Cached blk
forall blk. Cached blk -> Cached blk
addCurrentChunkOffsets
  where
    -- Lenses would be nice here
    addCurrentChunkOffsets :: Cached blk -> Cached blk
    addCurrentChunkOffsets :: Cached blk -> Cached blk
addCurrentChunkOffsets cached :: Cached blk
cached@Cached { CurrentChunkInfo blk
currentChunkInfo :: CurrentChunkInfo blk
$sel:currentChunkInfo:Cached :: forall blk. Cached blk -> CurrentChunkInfo blk
currentChunkInfo } = Cached blk
cached
      { $sel:currentChunkInfo:Cached :: CurrentChunkInfo blk
currentChunkInfo = CurrentChunkInfo blk
currentChunkInfo
        { $sel:currentChunkOffsets:CurrentChunkInfo :: StrictSeq Word32
currentChunkOffsets = CurrentChunkInfo blk -> StrictSeq Word32
forall blk. CurrentChunkInfo blk -> StrictSeq Word32
currentChunkOffsets CurrentChunkInfo blk
currentChunkInfo StrictSeq Word32 -> StrictSeq Word32 -> StrictSeq Word32
forall a. Semigroup a => a -> a -> a
<>
                                [Word32] -> StrictSeq Word32
forall a. [a] -> StrictSeq a
Seq.fromList (f Word32 -> [Word32]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f Word32
offsets)
        }
      }

{------------------------------------------------------------------------------
  On the secondary index
------------------------------------------------------------------------------}

readEntries
  :: forall m blk h t.
     ( HasCallStack
     , ConvertRawHash blk
     , IOLike m
     , StandardHash blk
     , Typeable blk
     , Traversable t
     )
  => CacheEnv m blk h
  -> ChunkNo
  -> t (IsEBB, SecondaryOffset)
  -> m (t (Secondary.Entry blk, BlockSize))
readEntries :: CacheEnv m blk h
-> ChunkNo -> t (IsEBB, Word32) -> m (t (Entry blk, BlockSize))
readEntries CacheEnv m blk h
cacheEnv ChunkNo
chunk t (IsEBB, Word32)
toRead =
    CacheEnv m blk h
-> ChunkNo -> m (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
forall (m :: * -> *) blk h.
(HasCallStack, ConvertRawHash blk, IOLike m, StandardHash blk,
 Typeable blk) =>
CacheEnv m blk h
-> ChunkNo -> m (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
getChunkInfo CacheEnv m blk h
cacheEnv ChunkNo
chunk m (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
-> (Either (CurrentChunkInfo blk) (PastChunkInfo blk)
    -> m (t (Entry blk, BlockSize)))
-> m (t (Entry blk, BlockSize))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left CurrentChunkInfo { StrictSeq (Entry blk)
currentChunkEntries :: StrictSeq (Entry blk)
$sel:currentChunkEntries:CurrentChunkInfo :: forall blk. CurrentChunkInfo blk -> StrictSeq (Entry blk)
currentChunkEntries } ->
        t (IsEBB, Word32)
-> ((IsEBB, Word32) -> m (Entry blk, BlockSize))
-> m (t (Entry blk, BlockSize))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM t (IsEBB, Word32)
toRead (((IsEBB, Word32) -> m (Entry blk, BlockSize))
 -> m (t (Entry blk, BlockSize)))
-> ((IsEBB, Word32) -> m (Entry blk, BlockSize))
-> m (t (Entry blk, BlockSize))
forall a b. (a -> b) -> a -> b
$ \(IsEBB
_isEBB, Word32
secondaryOffset) ->
          case StrictSeq (Entry blk)
currentChunkEntries StrictSeq (Entry blk) -> Int -> Maybe (Entry blk)
forall a. StrictSeq a -> Int -> Maybe a
Seq.!? Word32 -> Int
indexForOffset Word32
secondaryOffset of
            Just (WithBlockSize Word32
size Entry blk
entry) -> (Entry blk, BlockSize) -> m (Entry blk, BlockSize)
forall (m :: * -> *) a. Monad m => a -> m a
return (Entry blk
entry, Word32 -> BlockSize
BlockSize Word32
size)
            Maybe (Entry blk)
Nothing                         -> Word32 -> m (Entry blk, BlockSize)
forall a. Word32 -> m a
noEntry Word32
secondaryOffset
      Right PastChunkInfo { Vector (Entry blk)
pastChunkEntries :: Vector (Entry blk)
$sel:pastChunkEntries:PastChunkInfo :: forall blk. PastChunkInfo blk -> Vector (Entry blk)
pastChunkEntries } ->
        t (IsEBB, Word32)
-> ((IsEBB, Word32) -> m (Entry blk, BlockSize))
-> m (t (Entry blk, BlockSize))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM t (IsEBB, Word32)
toRead (((IsEBB, Word32) -> m (Entry blk, BlockSize))
 -> m (t (Entry blk, BlockSize)))
-> ((IsEBB, Word32) -> m (Entry blk, BlockSize))
-> m (t (Entry blk, BlockSize))
forall a b. (a -> b) -> a -> b
$ \(IsEBB
_isEBB, Word32
secondaryOffset) ->
          case Vector (Entry blk)
pastChunkEntries Vector (Entry blk) -> Int -> Maybe (Entry blk)
forall a. Vector a -> Int -> Maybe a
Vector.!? Word32 -> Int
indexForOffset Word32
secondaryOffset of
            Just (WithBlockSize Word32
size Entry blk
entry) -> (Entry blk, BlockSize) -> m (Entry blk, BlockSize)
forall (m :: * -> *) a. Monad m => a -> m a
return (Entry blk
entry, Word32 -> BlockSize
BlockSize Word32
size)
            Maybe (Entry blk)
Nothing                         -> Word32 -> m (Entry blk, BlockSize)
forall a. Word32 -> m a
noEntry Word32
secondaryOffset
  where
    indexForOffset :: SecondaryOffset -> Int
    indexForOffset :: Word32 -> Int
indexForOffset Word32
secondaryOffset = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$
      Word32
secondaryOffset Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`div` Proxy blk -> Word32
forall blk. ConvertRawHash blk => Proxy blk -> Word32
Secondary.entrySize (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk)

    -- There was no entry in the secondary index for the given
    -- 'SecondaryOffset'. Either the secondary index is incomplete, /or/, the
    -- primary index from which we read the 'SecondaryOffset' got corrupted.
    -- We don't know which of the two things happened, but the former is more
    -- likely, so we mention that file in the error message.
    noEntry :: SecondaryOffset -> m a
    noEntry :: Word32 -> m a
noEntry Word32
secondaryOffset = UnexpectedFailure blk -> m a
forall blk (m :: * -> *) a.
(StandardHash blk, Typeable blk, MonadThrow m) =>
UnexpectedFailure blk -> m a
throwUnexpectedFailure (UnexpectedFailure blk -> m a) -> UnexpectedFailure blk -> m a
forall a b. (a -> b) -> a -> b
$ FsPath -> String -> PrettyCallStack -> UnexpectedFailure blk
forall blk.
FsPath -> String -> PrettyCallStack -> UnexpectedFailure blk
InvalidFileError @blk
      (ChunkNo -> FsPath
fsPathSecondaryIndexFile ChunkNo
chunk)
      (String
"no entry missing for " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word32 -> String
forall a. Show a => a -> String
show Word32
secondaryOffset)
      PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack

readAllEntries
  :: forall m blk h.
     ( HasCallStack
     , ConvertRawHash blk
     , IOLike m
     , StandardHash blk
     , Typeable blk
     )
  => CacheEnv m blk h
  -> SecondaryOffset
  -> ChunkNo
  -> (Secondary.Entry blk -> Bool)
  -> Word64
  -> IsEBB
  -> m [WithBlockSize (Secondary.Entry blk)]
readAllEntries :: CacheEnv m blk h
-> Word32
-> ChunkNo
-> (Entry blk -> Bool)
-> Word64
-> IsEBB
-> m [WithBlockSize (Entry blk)]
readAllEntries CacheEnv m blk h
cacheEnv Word32
secondaryOffset ChunkNo
chunk Entry blk -> Bool
stopCondition
               Word64
_chunkFileSize IsEBB
_firstIsEBB =
    CacheEnv m blk h
-> ChunkNo -> m (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
forall (m :: * -> *) blk h.
(HasCallStack, ConvertRawHash blk, IOLike m, StandardHash blk,
 Typeable blk) =>
CacheEnv m blk h
-> ChunkNo -> m (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
getChunkInfo CacheEnv m blk h
cacheEnv ChunkNo
chunk m (Either (CurrentChunkInfo blk) (PastChunkInfo blk))
-> (Either (CurrentChunkInfo blk) (PastChunkInfo blk)
    -> [WithBlockSize (Entry blk)])
-> m [WithBlockSize (Entry blk)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
      Left CurrentChunkInfo { StrictSeq (WithBlockSize (Entry blk))
currentChunkEntries :: StrictSeq (WithBlockSize (Entry blk))
$sel:currentChunkEntries:CurrentChunkInfo :: forall blk. CurrentChunkInfo blk -> StrictSeq (Entry blk)
currentChunkEntries } ->
        (WithBlockSize (Entry blk) -> Bool)
-> [WithBlockSize (Entry blk)] -> [WithBlockSize (Entry blk)]
forall a. (a -> Bool) -> [a] -> [a]
takeUntil (Entry blk -> Bool
stopCondition (Entry blk -> Bool)
-> (WithBlockSize (Entry blk) -> Entry blk)
-> WithBlockSize (Entry blk)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithBlockSize (Entry blk) -> Entry blk
forall a. WithBlockSize a -> a
withoutBlockSize) ([WithBlockSize (Entry blk)] -> [WithBlockSize (Entry blk)])
-> [WithBlockSize (Entry blk)] -> [WithBlockSize (Entry blk)]
forall a b. (a -> b) -> a -> b
$
        StrictSeq (WithBlockSize (Entry blk))
-> [WithBlockSize (Entry blk)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (WithBlockSize (Entry blk))
 -> [WithBlockSize (Entry blk)])
-> StrictSeq (WithBlockSize (Entry blk))
-> [WithBlockSize (Entry blk)]
forall a b. (a -> b) -> a -> b
$ Int
-> StrictSeq (WithBlockSize (Entry blk))
-> StrictSeq (WithBlockSize (Entry blk))
forall a. Int -> StrictSeq a -> StrictSeq a
Seq.drop Int
toDrop StrictSeq (WithBlockSize (Entry blk))
currentChunkEntries
      Right PastChunkInfo { Vector (WithBlockSize (Entry blk))
pastChunkEntries :: Vector (WithBlockSize (Entry blk))
$sel:pastChunkEntries:PastChunkInfo :: forall blk. PastChunkInfo blk -> Vector (Entry blk)
pastChunkEntries } ->
        (WithBlockSize (Entry blk) -> Bool)
-> [WithBlockSize (Entry blk)] -> [WithBlockSize (Entry blk)]
forall a. (a -> Bool) -> [a] -> [a]
takeUntil (Entry blk -> Bool
stopCondition (Entry blk -> Bool)
-> (WithBlockSize (Entry blk) -> Entry blk)
-> WithBlockSize (Entry blk)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithBlockSize (Entry blk) -> Entry blk
forall a. WithBlockSize a -> a
withoutBlockSize) ([WithBlockSize (Entry blk)] -> [WithBlockSize (Entry blk)])
-> [WithBlockSize (Entry blk)] -> [WithBlockSize (Entry blk)]
forall a b. (a -> b) -> a -> b
$
        Vector (WithBlockSize (Entry blk)) -> [WithBlockSize (Entry blk)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Vector (WithBlockSize (Entry blk)) -> [WithBlockSize (Entry blk)])
-> Vector (WithBlockSize (Entry blk))
-> [WithBlockSize (Entry blk)]
forall a b. (a -> b) -> a -> b
$ Int
-> Vector (WithBlockSize (Entry blk))
-> Vector (WithBlockSize (Entry blk))
forall a. Int -> Vector a -> Vector a
Vector.drop Int
toDrop Vector (WithBlockSize (Entry blk))
pastChunkEntries
  where
    toDrop :: Int
    toDrop :: Int
toDrop = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$
      Word32
secondaryOffset Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`div` Proxy blk -> Word32
forall blk. ConvertRawHash blk => Proxy blk -> Word32
Secondary.entrySize (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk)

appendEntry
  :: forall m blk h. (HasCallStack, ConvertRawHash blk, IOLike m)
  => CacheEnv m blk h
  -> ChunkNo
  -> Handle h
  -> Entry blk
  -> m Word64
appendEntry :: CacheEnv m blk h -> ChunkNo -> Handle h -> Entry blk -> m Word64
appendEntry CacheEnv { HasFS m h
hasFS :: HasFS m h
$sel:hasFS:CacheEnv :: forall (m :: * -> *) blk h. CacheEnv m blk h -> HasFS m h
hasFS, StrictMVar m (Cached blk)
cacheVar :: StrictMVar m (Cached blk)
$sel:cacheVar:CacheEnv :: forall (m :: * -> *) blk h.
CacheEnv m blk h -> StrictMVar m (Cached blk)
cacheVar } ChunkNo
chunk Handle h
sHnd Entry blk
entry = do
    Word64
nbBytes <- 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
sHnd (Entry blk -> Entry blk
forall a. WithBlockSize a -> a
withoutBlockSize Entry blk
entry)
    StrictMVar m (Cached blk) -> (Cached blk -> Cached blk) -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictMVar m a -> (a -> a) -> m ()
updateMVar_ StrictMVar m (Cached blk)
cacheVar Cached blk -> Cached blk
addCurrentChunkEntry
    Word64 -> m Word64
forall (m :: * -> *) a. Monad m => a -> m a
return Word64
nbBytes
  where
    -- Lenses would be nice here
    addCurrentChunkEntry :: Cached blk -> Cached blk
    addCurrentChunkEntry :: Cached blk -> Cached blk
addCurrentChunkEntry cached :: Cached blk
cached@Cached { ChunkNo
currentChunk :: ChunkNo
$sel:currentChunk:Cached :: forall blk. Cached blk -> ChunkNo
currentChunk, CurrentChunkInfo blk
currentChunkInfo :: CurrentChunkInfo blk
$sel:currentChunkInfo:Cached :: forall blk. Cached blk -> CurrentChunkInfo blk
currentChunkInfo }
      | ChunkNo
currentChunk ChunkNo -> ChunkNo -> Bool
forall a. Eq a => a -> a -> Bool
/= ChunkNo
chunk
      = String -> Cached blk
forall a. HasCallStack => String -> a
error (String -> Cached blk) -> String -> Cached blk
forall a b. (a -> b) -> a -> b
$
          String
"Appending to chunk " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ChunkNo -> String
forall a. Show a => a -> String
show ChunkNo
chunk String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
          String
" while the index is still in " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ChunkNo -> String
forall a. Show a => a -> String
show ChunkNo
currentChunk
      | Bool
otherwise
      = Cached blk
cached
          { $sel:currentChunkInfo:Cached :: CurrentChunkInfo blk
currentChunkInfo = CurrentChunkInfo blk
currentChunkInfo
            { $sel:currentChunkEntries:CurrentChunkInfo :: StrictSeq (Entry blk)
currentChunkEntries =
                CurrentChunkInfo blk -> StrictSeq (Entry blk)
forall blk. CurrentChunkInfo blk -> StrictSeq (Entry blk)
currentChunkEntries CurrentChunkInfo blk
currentChunkInfo StrictSeq (Entry blk) -> Entry blk -> StrictSeq (Entry blk)
forall a. StrictSeq a -> a -> StrictSeq a
Seq.|> Entry blk
entry
            }
          }