{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | What the ChainDB knows about Leios endorser blocks: which closures it has
-- acquired, and so which blocks certifying an endorser block ChainSel may
-- select; and which claims some valid certificate has established.
module Ouroboros.Consensus.Storage.ChainDB.Impl.Leios
  ( -- * The Leios facts of a block
    leiosBlockInfo

    -- * Acquired closures
  , AcquiredLeiosEbs
  , mkAcquiredLeiosEbs
  , insertAcquiredLeiosEb
  , isAcquiredLeiosEb
  , pruneAcquiredLeiosEbs

    -- * Parking
  , ignoreParkedCertRB
  , ignoreParkedCertRBSuc

    -- * Valid claims
  , LeiosValidClaims
  , emptyLeiosValidClaims
  , insertLeiosValidClaim
  , isLeiosValidClaim
  , pruneLeiosValidClaims
  ) where

import Control.Monad (guard)
import qualified Data.List as List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (maybeToStrictMaybe, strictMaybeToMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Set.NonEmpty (NESet)
import qualified Data.Set.NonEmpty as NESet
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Leios.Cert (LeiosClaim (..))
import Ouroboros.Consensus.Leios.Protocol
  ( LeiosAnnouncement (..)
  , LeiosProtocol (..)
  )
import Ouroboros.Consensus.Leios.Types
  ( EndorserBlockHash
  , LeiosPoint (..)
  , RankingBlockHash
  )
import Ouroboros.Consensus.Storage.VolatileDB
  ( BlockInfo (..)
  , LeiosBlockInfo (..)
  )

{-------------------------------------------------------------------------------
  The Leios facts of a block
-------------------------------------------------------------------------------}

-- | What the block says about Leios endorser blocks, read off its header.
leiosBlockInfo ::
  forall blk.
  BlockSupportsProtocol blk =>
  BlockConfig blk ->
  blk ->
  LeiosBlockInfo
leiosBlockInfo :: forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> blk -> LeiosBlockInfo
leiosBlockInfo BlockConfig blk
bcfg blk
blk =
  LeiosBlockInfo
    { lbiHasCert :: Bool
lbiHasCert = Proxy (BlockProtocol blk)
-> ValidateView (BlockProtocol blk) -> Bool
forall p (proxy :: * -> *).
LeiosProtocol p =>
proxy p -> ValidateView p -> Bool
forall (proxy :: * -> *).
proxy (BlockProtocol blk)
-> ValidateView (BlockProtocol blk) -> Bool
getContainsLeiosCert Proxy (BlockProtocol blk)
p ValidateView (BlockProtocol blk)
view
    , lbiAnnouncedEb :: StrictMaybe EndorserBlockHash
lbiAnnouncedEb =
        Maybe EndorserBlockHash -> StrictMaybe EndorserBlockHash
forall a. Maybe a -> StrictMaybe a
maybeToStrictMaybe (Maybe EndorserBlockHash -> StrictMaybe EndorserBlockHash)
-> Maybe EndorserBlockHash -> StrictMaybe EndorserBlockHash
forall a b. (a -> b) -> a -> b
$ LeiosAnnouncement -> EndorserBlockHash
announcementEbHash (LeiosAnnouncement -> EndorserBlockHash)
-> Maybe LeiosAnnouncement -> Maybe EndorserBlockHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy (BlockProtocol blk)
-> ValidateView (BlockProtocol blk) -> Maybe LeiosAnnouncement
forall p (proxy :: * -> *).
LeiosProtocol p =>
proxy p -> ValidateView p -> Maybe LeiosAnnouncement
forall (proxy :: * -> *).
proxy (BlockProtocol blk)
-> ValidateView (BlockProtocol blk) -> Maybe LeiosAnnouncement
getLeiosAnnouncement Proxy (BlockProtocol blk)
p ValidateView (BlockProtocol blk)
view
    }
 where
  p :: Proxy (BlockProtocol blk)
p = forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(BlockProtocol blk)
  view :: ValidateView (BlockProtocol blk)
view = BlockConfig blk -> Header blk -> ValidateView (BlockProtocol blk)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> ValidateView (BlockProtocol blk)
validateView BlockConfig blk
bcfg (blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
blk)

{-------------------------------------------------------------------------------
  Acquired closures
-------------------------------------------------------------------------------}

-- | The endorser blocks whose closure the LeiosDB holds, each with the slot of
-- its youngest focus (see @LeiosEbNotification@).
--
-- That slot is the youngest slot of any 'LeiosPoint' in an @AcquiredEbTxs@
-- notification for the endorser block, since the LeiosDB sends that
-- notification at every focus not older than the ImmutableDB tip.
--
-- 'UnsafeAcquiredLeiosEbs' does not ensure that 'aleBySlot' is the inverse of
-- 'aleYoungestSlot'; build one with 'mkAcquiredLeiosEbs' instead.
data AcquiredLeiosEbs = UnsafeAcquiredLeiosEbs
  { AcquiredLeiosEbs -> Map EndorserBlockHash SlotNo
aleYoungestSlot :: !(Map EndorserBlockHash SlotNo)
  , AcquiredLeiosEbs -> Map SlotNo (NESet EndorserBlockHash)
aleBySlot :: !(Map SlotNo (NESet EndorserBlockHash))
  -- ^ The inverse of 'aleYoungestSlot', so that pruning costs only what it
  -- prunes.
  }
  deriving stock (forall x. AcquiredLeiosEbs -> Rep AcquiredLeiosEbs x)
-> (forall x. Rep AcquiredLeiosEbs x -> AcquiredLeiosEbs)
-> Generic AcquiredLeiosEbs
forall x. Rep AcquiredLeiosEbs x -> AcquiredLeiosEbs
forall x. AcquiredLeiosEbs -> Rep AcquiredLeiosEbs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. AcquiredLeiosEbs -> Rep AcquiredLeiosEbs x
from :: forall x. AcquiredLeiosEbs -> Rep AcquiredLeiosEbs x
$cto :: forall x. Rep AcquiredLeiosEbs x -> AcquiredLeiosEbs
to :: forall x. Rep AcquiredLeiosEbs x -> AcquiredLeiosEbs
Generic
  deriving anyclass Context -> AcquiredLeiosEbs -> IO (Maybe ThunkInfo)
Proxy AcquiredLeiosEbs -> String
(Context -> AcquiredLeiosEbs -> IO (Maybe ThunkInfo))
-> (Context -> AcquiredLeiosEbs -> IO (Maybe ThunkInfo))
-> (Proxy AcquiredLeiosEbs -> String)
-> NoThunks AcquiredLeiosEbs
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> AcquiredLeiosEbs -> IO (Maybe ThunkInfo)
noThunks :: Context -> AcquiredLeiosEbs -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> AcquiredLeiosEbs -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> AcquiredLeiosEbs -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy AcquiredLeiosEbs -> String
showTypeOf :: Proxy AcquiredLeiosEbs -> String
NoThunks

mkAcquiredLeiosEbs :: [LeiosPoint] -> AcquiredLeiosEbs
mkAcquiredLeiosEbs :: [LeiosPoint] -> AcquiredLeiosEbs
mkAcquiredLeiosEbs =
  (AcquiredLeiosEbs -> LeiosPoint -> AcquiredLeiosEbs)
-> AcquiredLeiosEbs -> [LeiosPoint] -> AcquiredLeiosEbs
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((LeiosPoint -> AcquiredLeiosEbs -> AcquiredLeiosEbs)
-> AcquiredLeiosEbs -> LeiosPoint -> AcquiredLeiosEbs
forall a b c. (a -> b -> c) -> b -> a -> c
flip LeiosPoint -> AcquiredLeiosEbs -> AcquiredLeiosEbs
insertAcquiredLeiosEb) (Map EndorserBlockHash SlotNo
-> Map SlotNo (NESet EndorserBlockHash) -> AcquiredLeiosEbs
UnsafeAcquiredLeiosEbs Map EndorserBlockHash SlotNo
forall k a. Map k a
Map.empty Map SlotNo (NESet EndorserBlockHash)
forall k a. Map k a
Map.empty)

-- | Record that the endorser block's closure is acquired, and that the given
-- point announces it.
insertAcquiredLeiosEb :: LeiosPoint -> AcquiredLeiosEbs -> AcquiredLeiosEbs
insertAcquiredLeiosEb :: LeiosPoint -> AcquiredLeiosEbs -> AcquiredLeiosEbs
insertAcquiredLeiosEb (MkLeiosPoint SlotNo
slot EndorserBlockHash
ebHash) acquired :: AcquiredLeiosEbs
acquired@(UnsafeAcquiredLeiosEbs Map EndorserBlockHash SlotNo
youngest Map SlotNo (NESet EndorserBlockHash)
bySlot) =
  case EndorserBlockHash -> Map EndorserBlockHash SlotNo -> Maybe SlotNo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup EndorserBlockHash
ebHash Map EndorserBlockHash SlotNo
youngest of
    Maybe SlotNo
Nothing -> Map SlotNo (NESet EndorserBlockHash) -> AcquiredLeiosEbs
record Map SlotNo (NESet EndorserBlockHash)
bySlot
    Just SlotNo
prevSlot
      | SlotNo
slot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo
prevSlot -> AcquiredLeiosEbs
acquired
      | Bool
otherwise -> Map SlotNo (NESet EndorserBlockHash) -> AcquiredLeiosEbs
record ((NESet EndorserBlockHash -> Maybe (NESet EndorserBlockHash))
-> SlotNo
-> Map SlotNo (NESet EndorserBlockHash)
-> Map SlotNo (NESet EndorserBlockHash)
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
Map.update (Set EndorserBlockHash -> Maybe (NESet EndorserBlockHash)
forall a. Set a -> Maybe (NESet a)
NESet.nonEmptySet (Set EndorserBlockHash -> Maybe (NESet EndorserBlockHash))
-> (NESet EndorserBlockHash -> Set EndorserBlockHash)
-> NESet EndorserBlockHash
-> Maybe (NESet EndorserBlockHash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EndorserBlockHash
-> NESet EndorserBlockHash -> Set EndorserBlockHash
forall a. Ord a => a -> NESet a -> Set a
NESet.delete EndorserBlockHash
ebHash) SlotNo
prevSlot Map SlotNo (NESet EndorserBlockHash)
bySlot)
 where
  record :: Map SlotNo (NESet EndorserBlockHash) -> AcquiredLeiosEbs
record Map SlotNo (NESet EndorserBlockHash)
bySlot' =
    Map EndorserBlockHash SlotNo
-> Map SlotNo (NESet EndorserBlockHash) -> AcquiredLeiosEbs
UnsafeAcquiredLeiosEbs
      (EndorserBlockHash
-> SlotNo
-> Map EndorserBlockHash SlotNo
-> Map EndorserBlockHash SlotNo
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert EndorserBlockHash
ebHash SlotNo
slot Map EndorserBlockHash SlotNo
youngest)
      ((NESet EndorserBlockHash
 -> NESet EndorserBlockHash -> NESet EndorserBlockHash)
-> SlotNo
-> NESet EndorserBlockHash
-> Map SlotNo (NESet EndorserBlockHash)
-> Map SlotNo (NESet EndorserBlockHash)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith NESet EndorserBlockHash
-> NESet EndorserBlockHash -> NESet EndorserBlockHash
forall a. Ord a => NESet a -> NESet a -> NESet a
NESet.union SlotNo
slot (EndorserBlockHash -> NESet EndorserBlockHash
forall a. a -> NESet a
NESet.singleton EndorserBlockHash
ebHash) Map SlotNo (NESet EndorserBlockHash)
bySlot')

isAcquiredLeiosEb :: EndorserBlockHash -> AcquiredLeiosEbs -> Bool
isAcquiredLeiosEb :: EndorserBlockHash -> AcquiredLeiosEbs -> Bool
isAcquiredLeiosEb EndorserBlockHash
ebHash = EndorserBlockHash -> Map EndorserBlockHash SlotNo -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member EndorserBlockHash
ebHash (Map EndorserBlockHash SlotNo -> Bool)
-> (AcquiredLeiosEbs -> Map EndorserBlockHash SlotNo)
-> AcquiredLeiosEbs
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AcquiredLeiosEbs -> Map EndorserBlockHash SlotNo
aleYoungestSlot

-- | Forget every endorser block all of whose foci are older than the slot. A
-- block that ChainSel has yet to select can then certify it only at another
-- announcement, and verifying that certificate makes the announcement a focus,
-- which records the endorser block here again.
--
-- See 'AcquiredLeiosEbs' for why its slots are the youngest foci.
pruneAcquiredLeiosEbs :: SlotNo -> AcquiredLeiosEbs -> AcquiredLeiosEbs
pruneAcquiredLeiosEbs :: SlotNo -> AcquiredLeiosEbs -> AcquiredLeiosEbs
pruneAcquiredLeiosEbs SlotNo
slot (UnsafeAcquiredLeiosEbs Map EndorserBlockHash SlotNo
youngest Map SlotNo (NESet EndorserBlockHash)
bySlot) =
  Map EndorserBlockHash SlotNo
-> Map SlotNo (NESet EndorserBlockHash) -> AcquiredLeiosEbs
UnsafeAcquiredLeiosEbs
    (Map EndorserBlockHash SlotNo
youngest Map EndorserBlockHash SlotNo
-> Set EndorserBlockHash -> Map EndorserBlockHash SlotNo
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.withoutKeys` (NESet EndorserBlockHash -> Set EndorserBlockHash)
-> Map SlotNo (NESet EndorserBlockHash) -> Set EndorserBlockHash
forall m a. Monoid m => (a -> m) -> Map SlotNo a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap NESet EndorserBlockHash -> Set EndorserBlockHash
forall a. NESet a -> Set a
NESet.toSet Map SlotNo (NESet EndorserBlockHash)
pruned)
    Map SlotNo (NESet EndorserBlockHash)
kept
 where
  (Map SlotNo (NESet EndorserBlockHash)
pruned, Map SlotNo (NESet EndorserBlockHash)
kept) = (SlotNo -> Bool)
-> Map SlotNo (NESet EndorserBlockHash)
-> (Map SlotNo (NESet EndorserBlockHash),
    Map SlotNo (NESet EndorserBlockHash))
forall k a. (k -> Bool) -> Map k a -> (Map k a, Map k a)
Map.spanAntitone (SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
slot) Map SlotNo (NESet EndorserBlockHash)
bySlot

{-------------------------------------------------------------------------------
  Parking
-------------------------------------------------------------------------------}

-- | Whether the block contains a certificate of an endorser block whose closure
-- is not acquired. ChainSel must not select such a block until it is, so it
-- treats the block as absent: the block is parked.
--
-- The certified endorser block is the one the block's predecessor announces.
isParkedCertRB ::
  AcquiredLeiosEbs ->
  (HeaderHash blk -> Maybe (BlockInfo blk)) ->
  BlockInfo blk ->
  Bool
isParkedCertRB :: forall blk.
AcquiredLeiosEbs
-> (HeaderHash blk -> Maybe (BlockInfo blk))
-> BlockInfo blk
-> Bool
isParkedCertRB AcquiredLeiosEbs
acquired HeaderHash blk -> Maybe (BlockInfo blk)
lookupBlockInfo BlockInfo blk
info
  | Bool -> Bool
not (LeiosBlockInfo -> Bool
lbiHasCert (BlockInfo blk -> LeiosBlockInfo
forall blk. BlockInfo blk -> LeiosBlockInfo
biLeios BlockInfo blk
info)) = Bool
False
  | Bool
otherwise = case Maybe EndorserBlockHash
certifiedEb of
      Just EndorserBlockHash
ebHash -> Bool -> Bool
not (EndorserBlockHash -> AcquiredLeiosEbs -> Bool
isAcquiredLeiosEb EndorserBlockHash
ebHash AcquiredLeiosEbs
acquired)
      -- Either the VolatileDB lacks the predecessor, so the block cannot
      -- be selected before it arrives anyway, or the predecessor (perhaps
      -- genesis) announces nothing, so the block can never be valid and
      -- staying parked for good is harmless.
      Maybe EndorserBlockHash
Nothing -> Bool
True
 where
  certifiedEb :: Maybe EndorserBlockHash
certifiedEb = case BlockInfo blk -> ChainHash blk
forall blk. BlockInfo blk -> ChainHash blk
biPrevHash BlockInfo blk
info of
    ChainHash blk
GenesisHash -> Maybe EndorserBlockHash
forall a. Maybe a
Nothing
    BlockHash HeaderHash blk
prevHash ->
      HeaderHash blk -> Maybe (BlockInfo blk)
lookupBlockInfo HeaderHash blk
prevHash Maybe (BlockInfo blk)
-> (BlockInfo blk -> Maybe EndorserBlockHash)
-> Maybe EndorserBlockHash
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StrictMaybe EndorserBlockHash -> Maybe EndorserBlockHash
forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe (StrictMaybe EndorserBlockHash -> Maybe EndorserBlockHash)
-> (BlockInfo blk -> StrictMaybe EndorserBlockHash)
-> BlockInfo blk
-> Maybe EndorserBlockHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LeiosBlockInfo -> StrictMaybe EndorserBlockHash
lbiAnnouncedEb (LeiosBlockInfo -> StrictMaybe EndorserBlockHash)
-> (BlockInfo blk -> LeiosBlockInfo)
-> BlockInfo blk
-> StrictMaybe EndorserBlockHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockInfo blk -> LeiosBlockInfo
forall blk. BlockInfo blk -> LeiosBlockInfo
biLeios

-- | Hide parked blocks ('isParkedCertRB') from a @getBlockInfo@. The given one
-- must be the VolatileDB's own, so that it still finds every predecessor.
ignoreParkedCertRB ::
  AcquiredLeiosEbs ->
  (HeaderHash blk -> Maybe (BlockInfo blk)) ->
  (HeaderHash blk -> Maybe (BlockInfo blk))
ignoreParkedCertRB :: forall blk.
AcquiredLeiosEbs
-> (HeaderHash blk -> Maybe (BlockInfo blk))
-> HeaderHash blk
-> Maybe (BlockInfo blk)
ignoreParkedCertRB AcquiredLeiosEbs
acquired HeaderHash blk -> Maybe (BlockInfo blk)
lookupBlockInfo HeaderHash blk
hash = do
  info <- HeaderHash blk -> Maybe (BlockInfo blk)
lookupBlockInfo HeaderHash blk
hash
  guard (not (isParkedCertRB acquired lookupBlockInfo info))
  pure info

-- | Hide parked blocks ('isParkedCertRB') from a @filterByPredecessor@. The
-- given @getBlockInfo@ must be the VolatileDB's own.
ignoreParkedCertRBSuc ::
  AcquiredLeiosEbs ->
  (HeaderHash blk -> Maybe (BlockInfo blk)) ->
  (ChainHash blk -> Set (HeaderHash blk)) ->
  (ChainHash blk -> Set (HeaderHash blk))
ignoreParkedCertRBSuc :: forall blk.
AcquiredLeiosEbs
-> (HeaderHash blk -> Maybe (BlockInfo blk))
-> (ChainHash blk -> Set (HeaderHash blk))
-> ChainHash blk
-> Set (HeaderHash blk)
ignoreParkedCertRBSuc AcquiredLeiosEbs
acquired HeaderHash blk -> Maybe (BlockInfo blk)
lookupBlockInfo ChainHash blk -> Set (HeaderHash blk)
succsOf =
  (HeaderHash blk -> Bool)
-> Set (HeaderHash blk) -> Set (HeaderHash blk)
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Bool -> Bool
not (Bool -> Bool)
-> (HeaderHash blk -> Bool) -> HeaderHash blk -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderHash blk -> Bool
isParked) (Set (HeaderHash blk) -> Set (HeaderHash blk))
-> (ChainHash blk -> Set (HeaderHash blk))
-> ChainHash blk
-> Set (HeaderHash blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainHash blk -> Set (HeaderHash blk)
succsOf
 where
  isParked :: HeaderHash blk -> Bool
isParked = Bool -> (BlockInfo blk -> Bool) -> Maybe (BlockInfo blk) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (AcquiredLeiosEbs
-> (HeaderHash blk -> Maybe (BlockInfo blk))
-> BlockInfo blk
-> Bool
forall blk.
AcquiredLeiosEbs
-> (HeaderHash blk -> Maybe (BlockInfo blk))
-> BlockInfo blk
-> Bool
isParkedCertRB AcquiredLeiosEbs
acquired HeaderHash blk -> Maybe (BlockInfo blk)
lookupBlockInfo) (Maybe (BlockInfo blk) -> Bool)
-> (HeaderHash blk -> Maybe (BlockInfo blk))
-> HeaderHash blk
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderHash blk -> Maybe (BlockInfo blk)
lookupBlockInfo

{-------------------------------------------------------------------------------
  Valid claims
-------------------------------------------------------------------------------}

-- | The blocks known to announce an endorser block that some valid certificate
-- certifies, each with its slot.
--
-- A block containing a certificate claims that the endorser block its
-- predecessor announced is certified. The claims that valid certificates have
-- established are how LeiosFetch will learn which endorser blocks are
-- certified, for its Recovery Path; that part is not ported yet. Meanwhile, a
-- block making an already established claim need not have its certificate
-- verified.
data LeiosValidClaims = LeiosValidClaims
  { LeiosValidClaims -> Map RankingBlockHash SlotNo
lvcSlot :: !(Map RankingBlockHash SlotNo)
  , LeiosValidClaims -> Map SlotNo (NESet RankingBlockHash)
lvcBySlot :: !(Map SlotNo (NESet RankingBlockHash))
  -- ^ The inverse of 'lvcSlot', so that pruning costs only what it prunes.
  }
  deriving stock (forall x. LeiosValidClaims -> Rep LeiosValidClaims x)
-> (forall x. Rep LeiosValidClaims x -> LeiosValidClaims)
-> Generic LeiosValidClaims
forall x. Rep LeiosValidClaims x -> LeiosValidClaims
forall x. LeiosValidClaims -> Rep LeiosValidClaims x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LeiosValidClaims -> Rep LeiosValidClaims x
from :: forall x. LeiosValidClaims -> Rep LeiosValidClaims x
$cto :: forall x. Rep LeiosValidClaims x -> LeiosValidClaims
to :: forall x. Rep LeiosValidClaims x -> LeiosValidClaims
Generic
  deriving anyclass Context -> LeiosValidClaims -> IO (Maybe ThunkInfo)
Proxy LeiosValidClaims -> String
(Context -> LeiosValidClaims -> IO (Maybe ThunkInfo))
-> (Context -> LeiosValidClaims -> IO (Maybe ThunkInfo))
-> (Proxy LeiosValidClaims -> String)
-> NoThunks LeiosValidClaims
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> LeiosValidClaims -> IO (Maybe ThunkInfo)
noThunks :: Context -> LeiosValidClaims -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> LeiosValidClaims -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> LeiosValidClaims -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy LeiosValidClaims -> String
showTypeOf :: Proxy LeiosValidClaims -> String
NoThunks

emptyLeiosValidClaims :: LeiosValidClaims
emptyLeiosValidClaims :: LeiosValidClaims
emptyLeiosValidClaims = Map RankingBlockHash SlotNo
-> Map SlotNo (NESet RankingBlockHash) -> LeiosValidClaims
LeiosValidClaims Map RankingBlockHash SlotNo
forall k a. Map k a
Map.empty Map SlotNo (NESet RankingBlockHash)
forall k a. Map k a
Map.empty

-- | Record that some valid certificate established the claim.
insertLeiosValidClaim :: LeiosClaim -> LeiosValidClaims -> LeiosValidClaims
insertLeiosValidClaim :: LeiosClaim -> LeiosValidClaims -> LeiosValidClaims
insertLeiosValidClaim (LeiosClaim SlotNo
slot RankingBlockHash
rbHash) claims :: LeiosValidClaims
claims@(LeiosValidClaims Map RankingBlockHash SlotNo
slots Map SlotNo (NESet RankingBlockHash)
bySlot)
  | RankingBlockHash -> Map RankingBlockHash SlotNo -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member RankingBlockHash
rbHash Map RankingBlockHash SlotNo
slots = LeiosValidClaims
claims
  | Bool
otherwise =
      Map RankingBlockHash SlotNo
-> Map SlotNo (NESet RankingBlockHash) -> LeiosValidClaims
LeiosValidClaims
        (RankingBlockHash
-> SlotNo
-> Map RankingBlockHash SlotNo
-> Map RankingBlockHash SlotNo
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert RankingBlockHash
rbHash SlotNo
slot Map RankingBlockHash SlotNo
slots)
        ((NESet RankingBlockHash
 -> NESet RankingBlockHash -> NESet RankingBlockHash)
-> SlotNo
-> NESet RankingBlockHash
-> Map SlotNo (NESet RankingBlockHash)
-> Map SlotNo (NESet RankingBlockHash)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith NESet RankingBlockHash
-> NESet RankingBlockHash -> NESet RankingBlockHash
forall a. Ord a => NESet a -> NESet a -> NESet a
NESet.union SlotNo
slot (RankingBlockHash -> NESet RankingBlockHash
forall a. a -> NESet a
NESet.singleton RankingBlockHash
rbHash) Map SlotNo (NESet RankingBlockHash)
bySlot)

isLeiosValidClaim :: RankingBlockHash -> LeiosValidClaims -> Bool
isLeiosValidClaim :: RankingBlockHash -> LeiosValidClaims -> Bool
isLeiosValidClaim RankingBlockHash
rbHash = RankingBlockHash -> Map RankingBlockHash SlotNo -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member RankingBlockHash
rbHash (Map RankingBlockHash SlotNo -> Bool)
-> (LeiosValidClaims -> Map RankingBlockHash SlotNo)
-> LeiosValidClaims
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LeiosValidClaims -> Map RankingBlockHash SlotNo
lvcSlot

-- | Forget every claim whose announcing block is older than the slot: once the
-- immutable tip has passed it, no block that ChainSel has yet to select can
-- make the claim.
pruneLeiosValidClaims :: SlotNo -> LeiosValidClaims -> LeiosValidClaims
pruneLeiosValidClaims :: SlotNo -> LeiosValidClaims -> LeiosValidClaims
pruneLeiosValidClaims SlotNo
slot (LeiosValidClaims Map RankingBlockHash SlotNo
slots Map SlotNo (NESet RankingBlockHash)
bySlot) =
  Map RankingBlockHash SlotNo
-> Map SlotNo (NESet RankingBlockHash) -> LeiosValidClaims
LeiosValidClaims
    (Map RankingBlockHash SlotNo
slots Map RankingBlockHash SlotNo
-> Set RankingBlockHash -> Map RankingBlockHash SlotNo
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.withoutKeys` (NESet RankingBlockHash -> Set RankingBlockHash)
-> Map SlotNo (NESet RankingBlockHash) -> Set RankingBlockHash
forall m a. Monoid m => (a -> m) -> Map SlotNo a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap NESet RankingBlockHash -> Set RankingBlockHash
forall a. NESet a -> Set a
NESet.toSet Map SlotNo (NESet RankingBlockHash)
pruned)
    Map SlotNo (NESet RankingBlockHash)
kept
 where
  (Map SlotNo (NESet RankingBlockHash)
pruned, Map SlotNo (NESet RankingBlockHash)
kept) = (SlotNo -> Bool)
-> Map SlotNo (NESet RankingBlockHash)
-> (Map SlotNo (NESet RankingBlockHash),
    Map SlotNo (NESet RankingBlockHash))
forall k a. (k -> Bool) -> Map k a -> (Map k a, Map k a)
Map.spanAntitone (SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
slot) Map SlotNo (NESet RankingBlockHash)
bySlot