Merge #1701

1701: VolatileDB: Unify and extend getters r=mrBliss a=kderme

Related issue: #1684
This is done:
> Unify getIsMember and getPredecessor, and return BlockInfo

This is not done yet:
> Possibly unify it with getSuccessors too, e.g., using return a pair of both results.

Co-authored-by: kderme <[email protected]>
Co-authored-by: Thomas Winant <[email protected]>

ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs

@@ -311,10 +311,9 @@ chainSelectionForBlock
 chainSelectionForBlock cdb@CDB{..} blockCache hdr = do
     curSlot <- atomically $ getCurrentSlot cdbBlockchainTime
 
-    (invalid, isMember, succsOf, predecessor, curChain, tipPoint, ledgerDB)
-      <- atomically $ (,,,,,,)
+    (invalid, succsOf, predecessor, curChain, tipPoint, ledgerDB)
+      <- atomically $ (,,,,,)
           <$> (forgetFingerprint <$> readTVar cdbInvalid)
-          <*> VolDB.getIsMember     cdbVolDB
           <*> VolDB.getSuccessors   cdbVolDB
           <*> VolDB.getPredecessor  cdbVolDB
           <*> Query.getCurrentChain cdb
@@ -335,12 +334,12 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr = do
         i = castPoint $ AF.anchorPoint curChain
 
         -- Let these two functions ignore invalid blocks
-        isMember' = ignoreInvalid    cdb invalid isMember
-        succsOf'  = ignoreInvalidSuc cdb invalid succsOf
+        predecessor' = ignoreInvalid    cdb invalid predecessor
+        succsOf'     = ignoreInvalidSuc cdb invalid succsOf
 
     -- The preconditions
     assert (blockSlot hdr <= curSlot)  $ return ()
-    assert (isMember (headerHash hdr)) $ return ()
+    assert (isJust $ predecessor (headerHash hdr)) $ return ()
 
     if
       -- The chain might have grown since we added the block such that the
@@ -358,7 +357,7 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr = do
         trace (TryAddToCurrentChain p)
         addToCurrentChain succsOf' curChainAndLedger curSlot
 
-      | Just hashes <- VolDB.isReachable predecessor isMember' i p -> do
+      | Just hashes <- VolDB.isReachable predecessor' i p -> do
         -- ### Switch to a fork
         trace (TrySwitchToAFork p hashes)
         switchToAFork succsOf' curChainAndLedger hashes curSlot
@@ -968,17 +967,16 @@ truncateInvalidCandidate isInvalid (CandidateSuffix rollback suffix)
 -------------------------------------------------------------------------------}
 
 
--- | Wrap an @isMember@ function so that it returns 'False' for invalid
--- blocks.
+-- | Wrap a @getter@ function so that it returns 'Nothing' for invalid blocks.
 ignoreInvalid
   :: HasHeader blk
   => proxy blk
   -> InvalidBlocks blk
-  -> (HeaderHash blk -> Bool)
-  -> (HeaderHash blk -> Bool)
-ignoreInvalid _ invalid isMember hash
-    | Map.member hash invalid = False
-    | otherwise               = isMember hash
+  -> (HeaderHash blk -> Maybe a)
+  -> (HeaderHash blk -> Maybe a)
+ignoreInvalid _ invalid getter hash
+    | Map.member hash invalid = Nothing
+    | otherwise               = getter hash
 
 -- | Wrap a @successors@ function so that invalid blocks are not returned as
 -- successors.

ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/VolDB.hs

@@ -36,6 +36,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.VolDB (
   , getKnownBlockComponent
   , getBlockComponent
     -- * Wrappers
+  , getBlockInfo
   , getIsMember
   , getPredecessor
   , getSuccessors
@@ -65,7 +66,7 @@ import           Data.Bifunctor (first)
 import qualified Data.ByteString.Lazy as Lazy
 import           Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as NE
-import           Data.Maybe (mapMaybe)
+import           Data.Maybe (isJust, mapMaybe)
 import           Data.Proxy (Proxy (..))
 import           Data.Set (Set)
 import qualified Data.Set as Set
@@ -210,12 +211,18 @@ mkVolDB volDB decHeader decBlock encBlock isEBB addHdrEnv = VolDB {..}
   Wrappers
 -------------------------------------------------------------------------------}
 
-getIsMember :: VolDB m blk -> STM m (HeaderHash blk -> Bool)
-getIsMember db = withSTM db VolDB.getIsMember
+getBlockInfo
+  :: VolDB m blk
+  -> STM m (HeaderHash blk -> Maybe (VolDB.BlockInfo (HeaderHash blk)))
+getBlockInfo db = withSTM db VolDB.getBlockInfo
 
-getPredecessor :: VolDB m blk
-               -> STM m (HeaderHash blk -> WithOrigin (HeaderHash blk))
-getPredecessor db = withSTM db VolDB.getPredecessor
+getIsMember :: Functor (STM m) => VolDB m blk -> STM m (HeaderHash blk -> Bool)
+getIsMember = fmap (isJust .) . getBlockInfo
+
+getPredecessor :: Functor (STM m)
+               => VolDB m blk
+               -> STM m (HeaderHash blk -> Maybe (WithOrigin (HeaderHash blk)))
+getPredecessor = fmap (fmap VolDB.bpreBid .) . getBlockInfo
 
 getSuccessors :: VolDB m blk
               -> STM m (WithOrigin (HeaderHash blk) -> Set (HeaderHash blk))
@@ -282,9 +289,8 @@ isReachableSTM :: (IOLike m, HasHeader blk)
                                     -- the reachability of
                -> STM m (Maybe (NonEmpty (HeaderHash blk)))
 isReachableSTM volDB getI b = do
-    (predecessor, isMember, i) <- withSTM volDB $ \db ->
-      (,,) <$> VolDB.getPredecessor db <*> VolDB.getIsMember db <*> getI
-    return $ isReachable predecessor isMember i b
+    (predecessor, i) <- (,) <$> getPredecessor volDB <*> getI
+    return $ isReachable predecessor i b
 
 -- | Check whether the given point, corresponding to a block @B@, is reachable
 -- from the tip of the ImmutableDB (@I@) by chasing the predecessors.
@@ -296,13 +302,12 @@ isReachableSTM volDB getI b = do
 -- 'True' <=> for all transitive predecessors @B'@ of @B@ we have @B' ∈ V@ or
 -- @B' = I@.
 isReachable :: forall blk. (HasHeader blk, HasCallStack)
-            => (HeaderHash blk -> WithOrigin (HeaderHash blk))  -- ^ @getPredecessor@
-            -> (HeaderHash blk -> Bool)                         -- ^ @isMember@
+            => (HeaderHash blk -> Maybe (WithOrigin (HeaderHash blk)))
             -> Point blk                                        -- ^ @I@
             -> Point blk                                        -- ^ @B@
             -> Maybe (NonEmpty (HeaderHash blk))
-isReachable predecessor isMember i b =
-    case computePath predecessor isMember from to of
+isReachable predecessor i b =
+    case computePath predecessor from to of
       -- Bounds are not on the same fork
       Nothing   -> Nothing
       Just path -> case path of
@@ -331,32 +336,32 @@ isReachable predecessor isMember i b =
 -- See the documentation of 'Path'.
 computePath
   :: forall blk. HasHeader blk
-  => (HeaderHash blk -> WithOrigin (HeaderHash blk)) -- ^ @getPredecessor@
-  -> (HeaderHash blk -> Bool)                        -- ^ @isMember@
+  => (HeaderHash blk -> Maybe (WithOrigin (HeaderHash blk)))
+     -- Return the predecessor
   -> StreamFrom blk
   -> StreamTo   blk
   -> Maybe (Path blk)
-computePath predecessor isMember from to = case to of
+computePath predecessor from to = case to of
     StreamToInclusive GenesisPoint
       -> Nothing
     StreamToExclusive GenesisPoint
       -> Nothing
     StreamToInclusive (BlockPoint { withHash = end })
-      | isMember end     -> case from of
+      | Just prev <- predecessor end -> case from of
           -- Easier to handle this special case (@StreamFromInclusive start,
           -- StreamToInclusive end, start == end@) here:
           StreamFromInclusive (BlockPoint { withHash = start })
             | start == end -> return $ CompletelyInVolDB [end]
-          _                -> go [end] end
+          _                -> go [end] prev
       | otherwise        -> return $ NotInVolDB end
     StreamToExclusive (BlockPoint { withHash = end })
-      | isMember end     -> go [] end
-      | otherwise        -> return $ NotInVolDB end
+      | Just prev <- predecessor end -> go [] prev
+      | otherwise                    -> return $ NotInVolDB end
   where
-    -- Invariant: @isMember hash@ and @hash@ has been added to @acc@ (if
-    -- allowed by the bounds)
-    go :: [HeaderHash blk] -> HeaderHash blk -> Maybe (Path blk)
-    go acc hash = case predecessor hash of
+    -- | It only needs the predecessor @prev@ and not the actual hash, because
+    -- the hash is already added to @acc@ (if allowed by the bounds).
+    go :: [HeaderHash blk] -> WithOrigin (HeaderHash blk) -> Maybe (Path blk)
+    go acc prev = case prev of
       -- Found genesis
       Origin -> case from of
         StreamFromInclusive _
@@ -367,15 +372,15 @@ computePath predecessor isMember from to = case to of
           -> Nothing
 
       At predHash
-        | isMember predHash -> case from of
+        | Just prev' <- predecessor predHash -> case from of
           StreamFromInclusive pt
             | BlockHash predHash == Block.pointHash pt
             -> return $ CompletelyInVolDB (predHash : acc)
           StreamFromExclusive pt
             | BlockHash predHash == Block.pointHash pt
             -> return $ CompletelyInVolDB acc
           -- Bound not yet reached, invariants both ok!
-          _ -> go (predHash : acc) predHash
+          _ -> go (predHash : acc) prev'
         -- Predecessor not in the VolatileDB
         | StreamFromExclusive pt <- from
         , BlockHash predHash == Block.pointHash pt
@@ -394,9 +399,8 @@ computePathSTM
   -> StreamTo   blk
   -> STM m (Path blk)
 computePathSTM volDB from to = do
-    (predecessor, isMember) <- withSTM volDB $ \db ->
-      (,) <$> VolDB.getPredecessor db <*> VolDB.getIsMember db
-    case computePath predecessor isMember from to of
+    predecessor <- getPredecessor volDB
+    case computePath predecessor from to of
       Just path -> return path
       Nothing   -> throwM $ InvalidIteratorRange from to
 

ouroboros-consensus/src/Ouroboros/Consensus/Storage/VolatileDB/API.hs

@@ -56,12 +56,10 @@ data VolatileDB blockId m = VolatileDB {
       -- Note that it is not required that the given block has been added to
       -- the VolatileDB.
     , getSuccessors     :: HasCallStack => STM m (WithOrigin blockId -> Set blockId)
-      -- | Return a function that returns the predecessor of the block with
-      -- the given @blockId@.
-      --
-      -- PRECONDITION: the block must be a member of the VolatileDB, you can
-      -- use 'getIsMember' to check this.
-    , getPredecessor    :: HasCallStack => STM m (blockId -> WithOrigin blockId)
+      -- | Return a function that returns the 'BlockInfo' of the block with
+      -- the given @blockId@ or 'Nothing' if the @blockId@ is not found in the
+      -- VolatileDB.
+    , getBlockInfo      :: HasCallStack => STM m (blockId -> Maybe (BlockInfo blockId))
       -- | Try to remove all blocks with a slot number less than the given
       -- one.
       --
@@ -119,7 +117,6 @@ data VolatileDB blockId m = VolatileDB {
       -- avoid issues with /EBBs/, which have the same slot number as the
       -- block after it.
     , garbageCollect    :: HasCallStack => SlotNo -> m ()
-    , getIsMember       :: HasCallStack => STM m (blockId -> Bool)
       -- | Return the highest slot number ever stored by the VolatileDB.
     , getMaxSlotNo      :: HasCallStack => STM m MaxSlotNo
 } deriving NoUnexpectedThunks via OnlyCheckIsWHNF "VolatileDB" (VolatileDB blockId m)

ouroboros-consensus/src/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs

@@ -197,9 +197,8 @@ openDB hasFS parser tracer maxBlocksPerFile = do
       , getBlockComponent = getBlockComponentImpl env
       , putBlock          = putBlockImpl          env
       , garbageCollect    = garbageCollectImpl    env
-      , getIsMember       = getIsMemberImpl       env
       , getSuccessors     = getSuccessorsImpl     env
-      , getPredecessor    = getPredecessorImpl    env
+      , getBlockInfo      = getBlockInfoImpl      env
       , getMaxSlotNo      = getMaxSlotNoImpl      env
       }
 
@@ -413,24 +412,17 @@ tryCollectFile hasFS VolatileDBEnv{..} slot st (fileId, fileInfo)
         mapMaybe (\b -> (b,) . bpreBid . ibBlockInfo <$> Map.lookup b _currentRevMap) bids
     succMap'          = foldl' deleteMapSet _currentSuccMap deletedPairs
 
-getIsMemberImpl :: forall m blockId. (IOLike m, Ord blockId)
-                => VolatileDBEnv m blockId
-                -> STM m (blockId -> Bool)
-getIsMemberImpl = getterSTM $ \st bid -> Map.member bid (_currentRevMap st)
-
 getSuccessorsImpl :: forall m blockId. (IOLike m, Ord blockId)
                   => VolatileDBEnv m blockId
                   -> STM m (WithOrigin blockId -> Set blockId)
 getSuccessorsImpl = getterSTM $ \st blockId ->
     fromMaybe Set.empty (Map.lookup blockId (_currentSuccMap st))
 
-getPredecessorImpl :: forall m blockId. (IOLike m, Ord blockId, HasCallStack)
-                   => VolatileDBEnv m blockId
-                   -> STM m (blockId -> WithOrigin blockId)
-getPredecessorImpl = getterSTM $ \st blockId ->
-    maybe (error msg) (bpreBid . ibBlockInfo) (Map.lookup blockId (_currentRevMap st))
-  where
-    msg = "precondition violated: block not member of the VolatileDB"
+getBlockInfoImpl :: forall m blockId. (IOLike m, Ord blockId)
+                 => VolatileDBEnv m blockId
+                 -> STM m (blockId -> Maybe (BlockInfo blockId))
+getBlockInfoImpl = getterSTM $ \st blockId ->
+    ibBlockInfo <$> Map.lookup blockId (_currentRevMap st)
 
 getMaxSlotNoImpl :: forall m blockId. IOLike m
                  => VolatileDBEnv m blockId

ouroboros-consensus/src/Ouroboros/Consensus/Storage/VolatileDB/Types.hs

@@ -159,7 +159,7 @@ data BlockInfo blockId = BlockInfo {
     , bisEBB        :: !IsEBB
     , bheaderOffset :: !Word16
     , bheaderSize   :: !Word16
-    } deriving (Show, Generic, NoUnexpectedThunks)
+    } deriving (Eq, Show, Generic, NoUnexpectedThunks)
 
 -- | The internal information the db keeps for each block.
 data InternalBlockInfo blockId = InternalBlockInfo {

ouroboros-consensus/test-storage/Test/Ouroboros/Storage/VolatileDB/Mock.hs

@@ -27,9 +27,8 @@ openDBMock maxBlocksPerFile = do
         , getBlockComponent = queryE   .: getBlockComponentModel
         , putBlock          = updateE_ .: putBlockModel
         , garbageCollect    = updateE_  . garbageCollectModel
-        , getIsMember       = querySTME $ getIsMemberModel
         , getSuccessors     = querySTME $ getSuccessorsModel
-        , getPredecessor    = querySTME $ getPredecessorModel
+        , getBlockInfo      = querySTME $ getBlockInfoModel
         , getMaxSlotNo      = querySTME $ getMaxSlotNoModel
         }
       where

ouroboros-consensus/test-storage/Test/Ouroboros/Storage/VolatileDB/Model.hs

@@ -16,9 +16,8 @@ module Test.Ouroboros.Storage.VolatileDB.Model
     , getBlockComponentModel
     , putBlockModel
     , garbageCollectModel
+    , getBlockInfoModel
     , getSuccessorsModel
-    , getPredecessorModel
-    , getIsMemberModel
     , getMaxSlotNoModel
       -- * Corruptions
     , runCorruptionsModel
@@ -317,21 +316,12 @@ getSuccessorsModel dbm = whenOpen dbm $ \predecessor ->
       Map.empty
       (getBlockToPredecessor dbm)
 
-getPredecessorModel
+getBlockInfoModel
   :: Ord blockId
   => DBModel blockId
-  -> Either VolatileDBError (blockId -> WithOrigin blockId)
-getPredecessorModel dbm = whenOpen dbm $ \blockId ->
-    fromMaybe (error msg) $ Map.lookup blockId $ getBlockToPredecessor dbm
-   where
-     msg = "precondition violated: block not member of the VolatileDB"
-
-getIsMemberModel
-  :: Ord blockId
-  => DBModel blockId
-  -> Either VolatileDBError (blockId -> Bool)
-getIsMemberModel dbm = whenOpen dbm $ \blockId ->
-    Map.member blockId (blockIndex dbm)
+  -> Either VolatileDBError (blockId -> Maybe (BlockInfo blockId))
+getBlockInfoModel dbm = whenOpen dbm $ \blockId ->
+    fst <$> Map.lookup blockId (blockIndex dbm)
 
 getMaxSlotNoModel
   :: DBModel blockId