{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}

module Ouroboros.Consensus.Storage.PerasCertDB.Impl
  ( -- * Opening
    PerasCertDbArgs (..)
  , defaultArgs
  , createDB

    -- * Trace types
  , TraceEvent (..)
  ) where

import Control.Monad (when)
import Control.Monad.Except (throwError)
import Control.Tracer (Tracer, nullTracer, traceWith)
import Data.Foldable (for_)
import Data.Kind (Type)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Generics (Generic)
import NoThunks.Class
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.BlockchainTime (WithArrivalTime (..))
import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot, mkPerasWeightSnapshot)
import Ouroboros.Consensus.Storage.PerasCertDB.API
import Ouroboros.Consensus.Util.Args
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.STM

{-------------------------------------------------------------------------------
  Database state
-------------------------------------------------------------------------------}

data PerasCertDbEnv m blk = PerasCertDbEnv
  { forall (m :: * -> *) blk.
PerasCertDbEnv m blk -> Tracer m (TraceEvent blk)
pcdbTracer :: !(Tracer m (TraceEvent blk))
  , forall (m :: * -> *) blk.
PerasCertDbEnv m blk
-> StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState :: !(StrictTVar m (WithFingerprint (PerasCertDbState blk)))
  -- ^ The volatile state of the certificate database.
  }
  deriving Context -> PerasCertDbEnv m blk -> IO (Maybe ThunkInfo)
Proxy (PerasCertDbEnv m blk) -> String
(Context -> PerasCertDbEnv m blk -> IO (Maybe ThunkInfo))
-> (Context -> PerasCertDbEnv m blk -> IO (Maybe ThunkInfo))
-> (Proxy (PerasCertDbEnv m blk) -> String)
-> NoThunks (PerasCertDbEnv m blk)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (m :: * -> *) blk.
Context -> PerasCertDbEnv m blk -> IO (Maybe ThunkInfo)
forall (m :: * -> *) blk. Proxy (PerasCertDbEnv m blk) -> String
$cnoThunks :: forall (m :: * -> *) blk.
Context -> PerasCertDbEnv m blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> PerasCertDbEnv m blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *) blk.
Context -> PerasCertDbEnv m blk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PerasCertDbEnv m blk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (m :: * -> *) blk. Proxy (PerasCertDbEnv m blk) -> String
showTypeOf :: Proxy (PerasCertDbEnv m blk) -> String
NoThunks via OnlyCheckWhnfNamed "PerasCertDbEnv" (PerasCertDbEnv m blk)

-- | INVARIANT: See 'invariantForPerasCertDbState'.
data PerasCertDbState blk = PerasCertDbState
  { forall blk. PerasCertDbState blk -> Set PerasRoundNo
pcdsCertIds :: !(Set PerasRoundNo)
  -- ^ The round numbers of all certificates currently in the db.
  , forall blk.
PerasCertDbState blk
-> Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
pcdsCertsByTicket :: !(Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk)))
  -- ^ The certificates by 'PerasCertTicketNo'.
  --
  -- INVARIANT: In sync with 'pcdsCertIds'.
  , forall blk. PerasCertDbState blk -> PerasCertTicketNo
pcdsLastTicketNo :: !PerasCertTicketNo
  -- ^ The most recent 'PerasCertTicketNo' (or 'zeroPerasCertTicketNo'
  -- otherwise).
  , forall blk.
PerasCertDbState blk
-> Maybe (WithArrivalTime (ValidatedPerasCert blk))
pcdsLatestCertSeen :: !(Maybe (WithArrivalTime (ValidatedPerasCert blk)))
  -- ^ The certificate with the highest round number that has been added to the
  -- db since it has been opened.
  }
  deriving stock (Int -> PerasCertDbState blk -> ShowS
[PerasCertDbState blk] -> ShowS
PerasCertDbState blk -> String
(Int -> PerasCertDbState blk -> ShowS)
-> (PerasCertDbState blk -> String)
-> ([PerasCertDbState blk] -> ShowS)
-> Show (PerasCertDbState blk)
forall blk.
StandardHash blk =>
Int -> PerasCertDbState blk -> ShowS
forall blk. StandardHash blk => [PerasCertDbState blk] -> ShowS
forall blk. StandardHash blk => PerasCertDbState blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk.
StandardHash blk =>
Int -> PerasCertDbState blk -> ShowS
showsPrec :: Int -> PerasCertDbState blk -> ShowS
$cshow :: forall blk. StandardHash blk => PerasCertDbState blk -> String
show :: PerasCertDbState blk -> String
$cshowList :: forall blk. StandardHash blk => [PerasCertDbState blk] -> ShowS
showList :: [PerasCertDbState blk] -> ShowS
Show, (forall x. PerasCertDbState blk -> Rep (PerasCertDbState blk) x)
-> (forall x. Rep (PerasCertDbState blk) x -> PerasCertDbState blk)
-> Generic (PerasCertDbState blk)
forall x. Rep (PerasCertDbState blk) x -> PerasCertDbState blk
forall x. PerasCertDbState blk -> Rep (PerasCertDbState blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (PerasCertDbState blk) x -> PerasCertDbState blk
forall blk x. PerasCertDbState blk -> Rep (PerasCertDbState blk) x
$cfrom :: forall blk x. PerasCertDbState blk -> Rep (PerasCertDbState blk) x
from :: forall x. PerasCertDbState blk -> Rep (PerasCertDbState blk) x
$cto :: forall blk x. Rep (PerasCertDbState blk) x -> PerasCertDbState blk
to :: forall x. Rep (PerasCertDbState blk) x -> PerasCertDbState blk
Generic)
  deriving anyclass Context -> PerasCertDbState blk -> IO (Maybe ThunkInfo)
Proxy (PerasCertDbState blk) -> String
(Context -> PerasCertDbState blk -> IO (Maybe ThunkInfo))
-> (Context -> PerasCertDbState blk -> IO (Maybe ThunkInfo))
-> (Proxy (PerasCertDbState blk) -> String)
-> NoThunks (PerasCertDbState blk)
forall blk.
StandardHash blk =>
Context -> PerasCertDbState blk -> IO (Maybe ThunkInfo)
forall blk.
StandardHash blk =>
Proxy (PerasCertDbState blk) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall blk.
StandardHash blk =>
Context -> PerasCertDbState blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> PerasCertDbState blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk.
StandardHash blk =>
Context -> PerasCertDbState blk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PerasCertDbState blk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall blk.
StandardHash blk =>
Proxy (PerasCertDbState blk) -> String
showTypeOf :: Proxy (PerasCertDbState blk) -> String
NoThunks

initialPerasCertDbState :: WithFingerprint (PerasCertDbState blk)
initialPerasCertDbState :: forall blk. WithFingerprint (PerasCertDbState blk)
initialPerasCertDbState =
  PerasCertDbState blk
-> Fingerprint -> WithFingerprint (PerasCertDbState blk)
forall a. a -> Fingerprint -> WithFingerprint a
WithFingerprint
    PerasCertDbState
      { pcdsCertIds :: Set PerasRoundNo
pcdsCertIds = Set PerasRoundNo
forall a. Set a
Set.empty
      , pcdsCertsByTicket :: Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
pcdsCertsByTicket = Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
forall k a. Map k a
Map.empty
      , pcdsLastTicketNo :: PerasCertTicketNo
pcdsLastTicketNo = PerasCertTicketNo
zeroPerasCertTicketNo
      , pcdsLatestCertSeen :: Maybe (WithArrivalTime (ValidatedPerasCert blk))
pcdsLatestCertSeen = Maybe (WithArrivalTime (ValidatedPerasCert blk))
forall a. Maybe a
Nothing
      }
    (Word64 -> Fingerprint
Fingerprint Word64
0)

-- | Check that the fields of 'PerasCertDbState' are in sync.
invariantForPerasCertDbState ::
  WithFingerprint (PerasCertDbState blk) -> Either String ()
invariantForPerasCertDbState :: forall blk.
WithFingerprint (PerasCertDbState blk) -> Either String ()
invariantForPerasCertDbState WithFingerprint (PerasCertDbState blk)
pcds = do
  String -> Set PerasRoundNo -> Set PerasRoundNo -> Either String ()
forall a. (Eq a, Show a) => String -> a -> a -> Either String ()
checkEqual
    String
"pcdsCertsByTicket"
    ([PerasRoundNo] -> Set PerasRoundNo
forall a. Ord a => [a] -> Set a
Set.fromList (WithArrivalTime (ValidatedPerasCert blk) -> PerasRoundNo
forall cert. HasPerasCertRound cert => cert -> PerasRoundNo
getPerasCertRound (WithArrivalTime (ValidatedPerasCert blk) -> PerasRoundNo)
-> [WithArrivalTime (ValidatedPerasCert blk)] -> [PerasRoundNo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
-> [WithArrivalTime (ValidatedPerasCert blk)]
forall k a. Map k a -> [a]
Map.elems Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
pcdsCertsByTicket))
    Set PerasRoundNo
pcdsCertIds
  [PerasCertTicketNo]
-> (PerasCertTicketNo -> Either String ()) -> Either String ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
-> [PerasCertTicketNo]
forall k a. Map k a -> [k]
Map.keys Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
pcdsCertsByTicket) ((PerasCertTicketNo -> Either String ()) -> Either String ())
-> (PerasCertTicketNo -> Either String ()) -> Either String ()
forall a b. (a -> b) -> a -> b
$ \PerasCertTicketNo
ticketNo ->
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PerasCertTicketNo
ticketNo PerasCertTicketNo -> PerasCertTicketNo -> Bool
forall a. Ord a => a -> a -> Bool
> PerasCertTicketNo
pcdsLastTicketNo) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
      String -> Either String ()
forall a. String -> Either String a
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
"Ticket number monotonicity violation: "
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PerasCertTicketNo -> String
forall a. Show a => a -> String
show PerasCertTicketNo
ticketNo
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" > "
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PerasCertTicketNo -> String
forall a. Show a => a -> String
show PerasCertTicketNo
pcdsLastTicketNo
 where
  PerasCertDbState
    { Set PerasRoundNo
pcdsCertIds :: forall blk. PerasCertDbState blk -> Set PerasRoundNo
pcdsCertIds :: Set PerasRoundNo
pcdsCertIds
    , Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
pcdsCertsByTicket :: forall blk.
PerasCertDbState blk
-> Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
pcdsCertsByTicket :: Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
pcdsCertsByTicket
    , PerasCertTicketNo
pcdsLastTicketNo :: forall blk. PerasCertDbState blk -> PerasCertTicketNo
pcdsLastTicketNo :: PerasCertTicketNo
pcdsLastTicketNo
    } = WithFingerprint (PerasCertDbState blk) -> PerasCertDbState blk
forall a. WithFingerprint a -> a
forgetFingerprint WithFingerprint (PerasCertDbState blk)
pcds

  checkEqual :: (Eq a, Show a) => String -> a -> a -> Either String ()
  checkEqual :: forall a. (Eq a, Show a) => String -> a -> a -> Either String ()
checkEqual String
msg a
a a
b =
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
b) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a. String -> Either String a
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
msg String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": Not equal: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
a String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
b

{-------------------------------------------------------------------------------
  Trace types
-------------------------------------------------------------------------------}

data TraceEvent blk
  = AddCert
      PerasRoundNo
      (WithArrivalTime (ValidatedPerasCert blk))
      AddPerasCertResult
  | GarbageCollected
      SlotNo
  deriving stock (Int -> TraceEvent blk -> ShowS
[TraceEvent blk] -> ShowS
TraceEvent blk -> String
(Int -> TraceEvent blk -> ShowS)
-> (TraceEvent blk -> String)
-> ([TraceEvent blk] -> ShowS)
-> Show (TraceEvent blk)
forall blk. StandardHash blk => Int -> TraceEvent blk -> ShowS
forall blk. StandardHash blk => [TraceEvent blk] -> ShowS
forall blk. StandardHash blk => TraceEvent blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk. StandardHash blk => Int -> TraceEvent blk -> ShowS
showsPrec :: Int -> TraceEvent blk -> ShowS
$cshow :: forall blk. StandardHash blk => TraceEvent blk -> String
show :: TraceEvent blk -> String
$cshowList :: forall blk. StandardHash blk => [TraceEvent blk] -> ShowS
showList :: [TraceEvent blk] -> ShowS
Show, TraceEvent blk -> TraceEvent blk -> Bool
(TraceEvent blk -> TraceEvent blk -> Bool)
-> (TraceEvent blk -> TraceEvent blk -> Bool)
-> Eq (TraceEvent blk)
forall blk.
StandardHash blk =>
TraceEvent blk -> TraceEvent blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk.
StandardHash blk =>
TraceEvent blk -> TraceEvent blk -> Bool
== :: TraceEvent blk -> TraceEvent blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
TraceEvent blk -> TraceEvent blk -> Bool
/= :: TraceEvent blk -> TraceEvent blk -> Bool
Eq, (forall x. TraceEvent blk -> Rep (TraceEvent blk) x)
-> (forall x. Rep (TraceEvent blk) x -> TraceEvent blk)
-> Generic (TraceEvent blk)
forall x. Rep (TraceEvent blk) x -> TraceEvent blk
forall x. TraceEvent blk -> Rep (TraceEvent blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (TraceEvent blk) x -> TraceEvent blk
forall blk x. TraceEvent blk -> Rep (TraceEvent blk) x
$cfrom :: forall blk x. TraceEvent blk -> Rep (TraceEvent blk) x
from :: forall x. TraceEvent blk -> Rep (TraceEvent blk) x
$cto :: forall blk x. Rep (TraceEvent blk) x -> TraceEvent blk
to :: forall x. Rep (TraceEvent blk) x -> TraceEvent blk
Generic)

{------------------------------------------------------------------------------
  Creating the database
------------------------------------------------------------------------------}

type PerasCertDbArgs :: (Type -> Type) -> (Type -> Type) -> Type -> Type
data PerasCertDbArgs f m blk = PerasCertDbArgs
  { forall (f :: * -> *) (m :: * -> *) blk.
PerasCertDbArgs f m blk -> Tracer m (TraceEvent blk)
pcdbaTracer :: Tracer m (TraceEvent blk)
  }

defaultArgs :: Applicative m => Incomplete PerasCertDbArgs m blk
defaultArgs :: forall (m :: * -> *) blk.
Applicative m =>
Incomplete PerasCertDbArgs m blk
defaultArgs =
  PerasCertDbArgs
    { pcdbaTracer :: Tracer m (TraceEvent blk)
pcdbaTracer = Tracer m (TraceEvent blk)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    }

createDB ::
  forall m blk.
  ( IOLike m
  , StandardHash blk
  ) =>
  Complete PerasCertDbArgs m blk ->
  m (PerasCertDB m blk)
createDB :: forall (m :: * -> *) blk.
(IOLike m, StandardHash blk) =>
Complete PerasCertDbArgs m blk -> m (PerasCertDB m blk)
createDB Complete PerasCertDbArgs m blk
args = do
  pcdbState <-
    (WithFingerprint (PerasCertDbState blk) -> Maybe String)
-> WithFingerprint (PerasCertDbState blk)
-> m (StrictTVar m (WithFingerprint (PerasCertDbState blk)))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
(a -> Maybe String) -> a -> m (StrictTVar m a)
newTVarWithInvariantIO
      ((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)
-> (WithFingerprint (PerasCertDbState blk) -> Either String ())
-> WithFingerprint (PerasCertDbState blk)
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithFingerprint (PerasCertDbState blk) -> Either String ()
forall blk.
WithFingerprint (PerasCertDbState blk) -> Either String ()
invariantForPerasCertDbState)
      WithFingerprint (PerasCertDbState blk)
forall blk. WithFingerprint (PerasCertDbState blk)
initialPerasCertDbState
  let env =
        PerasCertDbEnv
          { Tracer m (TraceEvent blk)
pcdbTracer :: Tracer m (TraceEvent blk)
pcdbTracer :: Tracer m (TraceEvent blk)
pcdbTracer
          , StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState :: StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState :: StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState
          }
  pure
    PerasCertDB
      { addCert = implAddCert env
      , getCertIds = implGetCertIds env
      , getCertsAfter = implGetCertsAfter env
      , getWeightSnapshot = implGetWeightSnapshot env
      , getLatestCertSeen = implGetLatestCertSeen env
      , garbageCollect = implGarbageCollect env
      }
 where
  PerasCertDbArgs
    { pcdbaTracer :: forall (f :: * -> *) (m :: * -> *) blk.
PerasCertDbArgs f m blk -> Tracer m (TraceEvent blk)
pcdbaTracer = Tracer m (TraceEvent blk)
pcdbTracer
    } = Complete PerasCertDbArgs m blk
args

{-------------------------------------------------------------------------------
  API implementation
-------------------------------------------------------------------------------}

-- TODO: we will need to update this method with non-trivial validation logic
-- see https://github.com/tweag/cardano-peras/issues/120
implAddCert ::
  IOLike m =>
  PerasCertDbEnv m blk ->
  WithArrivalTime (ValidatedPerasCert blk) ->
  STM m (m AddPerasCertResult)
implAddCert :: forall (m :: * -> *) blk.
IOLike m =>
PerasCertDbEnv m blk
-> WithArrivalTime (ValidatedPerasCert blk)
-> STM m (m AddPerasCertResult)
implAddCert PerasCertDbEnv{Tracer m (TraceEvent blk)
pcdbTracer :: forall (m :: * -> *) blk.
PerasCertDbEnv m blk -> Tracer m (TraceEvent blk)
pcdbTracer :: Tracer m (TraceEvent blk)
pcdbTracer, StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState :: forall (m :: * -> *) blk.
PerasCertDbEnv m blk
-> StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState :: StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState} WithArrivalTime (ValidatedPerasCert blk)
cert = do
  let roundNo :: PerasRoundNo
roundNo = WithArrivalTime (ValidatedPerasCert blk) -> PerasRoundNo
forall cert. HasPerasCertRound cert => cert -> PerasRoundNo
getPerasCertRound WithArrivalTime (ValidatedPerasCert blk)
cert
  addPerasCertRes <- do
    WithFingerprint pcds fp <- StrictTVar m (WithFingerprint (PerasCertDbState blk))
-> STM m (WithFingerprint (PerasCertDbState blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState
    if Set.member roundNo (pcdsCertIds pcds)
      then pure PerasCertAlreadyInDB
      else do
        let pcdsLastTicketNo' = PerasCertTicketNo -> PerasCertTicketNo
forall a. Enum a => a -> a
succ (PerasCertDbState blk -> PerasCertTicketNo
forall blk. PerasCertDbState blk -> PerasCertTicketNo
pcdsLastTicketNo PerasCertDbState blk
pcds)
            pcdsCertIds' = PerasRoundNo -> Set PerasRoundNo -> Set PerasRoundNo
forall a. Ord a => a -> Set a -> Set a
Set.insert PerasRoundNo
roundNo (PerasCertDbState blk -> Set PerasRoundNo
forall blk. PerasCertDbState blk -> Set PerasRoundNo
pcdsCertIds PerasCertDbState blk
pcds)
            pcdsCertsByTicket' = PerasCertTicketNo
-> WithArrivalTime (ValidatedPerasCert blk)
-> Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
-> Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PerasCertTicketNo
pcdsLastTicketNo' WithArrivalTime (ValidatedPerasCert blk)
cert (PerasCertDbState blk
-> Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
forall blk.
PerasCertDbState blk
-> Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
pcdsCertsByTicket PerasCertDbState blk
pcds)
            pcdsLatestCertSeen' = case PerasCertDbState blk
-> Maybe (WithArrivalTime (ValidatedPerasCert blk))
forall blk.
PerasCertDbState blk
-> Maybe (WithArrivalTime (ValidatedPerasCert blk))
pcdsLatestCertSeen PerasCertDbState blk
pcds of
              Maybe (WithArrivalTime (ValidatedPerasCert blk))
Nothing -> WithArrivalTime (ValidatedPerasCert blk)
-> Maybe (WithArrivalTime (ValidatedPerasCert blk))
forall a. a -> Maybe a
Just WithArrivalTime (ValidatedPerasCert blk)
cert
              Just WithArrivalTime (ValidatedPerasCert blk)
prev
                | WithArrivalTime (ValidatedPerasCert blk) -> PerasRoundNo
forall cert. HasPerasCertRound cert => cert -> PerasRoundNo
getPerasCertRound WithArrivalTime (ValidatedPerasCert blk)
cert PerasRoundNo -> PerasRoundNo -> Bool
forall a. Ord a => a -> a -> Bool
> WithArrivalTime (ValidatedPerasCert blk) -> PerasRoundNo
forall cert. HasPerasCertRound cert => cert -> PerasRoundNo
getPerasCertRound WithArrivalTime (ValidatedPerasCert blk)
prev -> WithArrivalTime (ValidatedPerasCert blk)
-> Maybe (WithArrivalTime (ValidatedPerasCert blk))
forall a. a -> Maybe a
Just WithArrivalTime (ValidatedPerasCert blk)
cert
                | Bool
otherwise -> WithArrivalTime (ValidatedPerasCert blk)
-> Maybe (WithArrivalTime (ValidatedPerasCert blk))
forall a. a -> Maybe a
Just WithArrivalTime (ValidatedPerasCert blk)
prev
        writeTVar pcdbState $
          WithFingerprint
            PerasCertDbState
              { pcdsCertIds = pcdsCertIds'
              , pcdsCertsByTicket = pcdsCertsByTicket'
              , pcdsLastTicketNo = pcdsLastTicketNo'
              , pcdsLatestCertSeen = pcdsLatestCertSeen'
              }
            (succ fp)
        pure AddedPerasCertToDB
  pure $ do
    traceWith pcdbTracer (AddCert roundNo cert addPerasCertRes)
    pure addPerasCertRes

implGetWeightSnapshot ::
  (IOLike m, StandardHash blk) =>
  PerasCertDbEnv m blk ->
  STM m (WithFingerprint (PerasWeightSnapshot blk))
implGetWeightSnapshot :: forall (m :: * -> *) blk.
(IOLike m, StandardHash blk) =>
PerasCertDbEnv m blk
-> STM m (WithFingerprint (PerasWeightSnapshot blk))
implGetWeightSnapshot PerasCertDbEnv{StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState :: forall (m :: * -> *) blk.
PerasCertDbEnv m blk
-> StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState :: StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState} = do
  WithFingerprint pcds fp <- StrictTVar m (WithFingerprint (PerasCertDbState blk))
-> STM m (WithFingerprint (PerasCertDbState blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState
  let weights =
        [(Point blk, PerasWeight)] -> PerasWeightSnapshot blk
forall blk.
StandardHash blk =>
[(Point blk, PerasWeight)] -> PerasWeightSnapshot blk
mkPerasWeightSnapshot
          [ (WithArrivalTime (ValidatedPerasCert blk) -> Point blk
forall cert blk.
HasPerasCertBoostedBlock cert blk =>
cert -> Point blk
getPerasCertBoostedBlock WithArrivalTime (ValidatedPerasCert blk)
cert, WithArrivalTime (ValidatedPerasCert blk) -> PerasWeight
forall cert. HasPerasCertBoost cert => cert -> PerasWeight
getPerasCertBoost WithArrivalTime (ValidatedPerasCert blk)
cert)
          | WithArrivalTime (ValidatedPerasCert blk)
cert <- Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
-> [WithArrivalTime (ValidatedPerasCert blk)]
forall k a. Map k a -> [a]
Map.elems (PerasCertDbState blk
-> Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
forall blk.
PerasCertDbState blk
-> Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
pcdsCertsByTicket PerasCertDbState blk
pcds)
          ]
  pure (WithFingerprint weights fp)

implGetCertIds ::
  IOLike m =>
  PerasCertDbEnv m blk ->
  STM m (Set PerasRoundNo)
implGetCertIds :: forall (m :: * -> *) blk.
IOLike m =>
PerasCertDbEnv m blk -> STM m (Set PerasRoundNo)
implGetCertIds PerasCertDbEnv{StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState :: forall (m :: * -> *) blk.
PerasCertDbEnv m blk
-> StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState :: StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState} = do
  PerasCertDbState{pcdsCertIds} <-
    WithFingerprint (PerasCertDbState blk) -> PerasCertDbState blk
forall a. WithFingerprint a -> a
forgetFingerprint (WithFingerprint (PerasCertDbState blk) -> PerasCertDbState blk)
-> STM m (WithFingerprint (PerasCertDbState blk))
-> STM m (PerasCertDbState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (WithFingerprint (PerasCertDbState blk))
-> STM m (WithFingerprint (PerasCertDbState blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState
  pure pcdsCertIds

implGetCertsAfter ::
  IOLike m =>
  PerasCertDbEnv m blk ->
  PerasCertTicketNo ->
  STM m (Map PerasCertTicketNo (m (WithArrivalTime (ValidatedPerasCert blk))))
implGetCertsAfter :: forall (m :: * -> *) blk.
IOLike m =>
PerasCertDbEnv m blk
-> PerasCertTicketNo
-> STM
     m
     (Map
        PerasCertTicketNo (m (WithArrivalTime (ValidatedPerasCert blk))))
implGetCertsAfter PerasCertDbEnv{StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState :: forall (m :: * -> *) blk.
PerasCertDbEnv m blk
-> StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState :: StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState} PerasCertTicketNo
ticketNo = do
  PerasCertDbState{pcdsCertsByTicket} <-
    WithFingerprint (PerasCertDbState blk) -> PerasCertDbState blk
forall a. WithFingerprint a -> a
forgetFingerprint (WithFingerprint (PerasCertDbState blk) -> PerasCertDbState blk)
-> STM m (WithFingerprint (PerasCertDbState blk))
-> STM m (PerasCertDbState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (WithFingerprint (PerasCertDbState blk))
-> STM m (WithFingerprint (PerasCertDbState blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState
  let strictlyGreater = (Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk)),
 Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk)))
-> Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
forall a b. (a, b) -> b
snd ((Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk)),
  Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk)))
 -> Map
      PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk)))
-> (Map
      PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk)),
    Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk)))
-> Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
forall a b. (a -> b) -> a -> b
$ PerasCertTicketNo
-> Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
-> (Map
      PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk)),
    Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk)))
forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
Map.split PerasCertTicketNo
ticketNo Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
pcdsCertsByTicket
  pure $ pure <$> strictlyGreater

implGetLatestCertSeen ::
  IOLike m =>
  PerasCertDbEnv m blk ->
  STM m (Maybe (WithArrivalTime (ValidatedPerasCert blk)))
implGetLatestCertSeen :: forall (m :: * -> *) blk.
IOLike m =>
PerasCertDbEnv m blk
-> STM m (Maybe (WithArrivalTime (ValidatedPerasCert blk)))
implGetLatestCertSeen PerasCertDbEnv{StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState :: forall (m :: * -> *) blk.
PerasCertDbEnv m blk
-> StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState :: StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState} = do
  PerasCertDbState{pcdsLatestCertSeen} <-
    WithFingerprint (PerasCertDbState blk) -> PerasCertDbState blk
forall a. WithFingerprint a -> a
forgetFingerprint (WithFingerprint (PerasCertDbState blk) -> PerasCertDbState blk)
-> STM m (WithFingerprint (PerasCertDbState blk))
-> STM m (PerasCertDbState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (WithFingerprint (PerasCertDbState blk))
-> STM m (WithFingerprint (PerasCertDbState blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState
  pure pcdsLatestCertSeen

implGarbageCollect ::
  forall m blk.
  IOLike m =>
  PerasCertDbEnv m blk ->
  SlotNo ->
  STM m (m ())
implGarbageCollect :: forall (m :: * -> *) blk.
IOLike m =>
PerasCertDbEnv m blk -> SlotNo -> STM m (m ())
implGarbageCollect PerasCertDbEnv{Tracer m (TraceEvent blk)
pcdbTracer :: forall (m :: * -> *) blk.
PerasCertDbEnv m blk -> Tracer m (TraceEvent blk)
pcdbTracer :: Tracer m (TraceEvent blk)
pcdbTracer, StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState :: forall (m :: * -> *) blk.
PerasCertDbEnv m blk
-> StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState :: StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState} SlotNo
slotNo = do
  -- No need to update the 'Fingerprint' as we only remove certificates that do
  -- not matter for comparing interesting chains.
  StrictTVar m (WithFingerprint (PerasCertDbState blk))
-> (WithFingerprint (PerasCertDbState blk)
    -> WithFingerprint (PerasCertDbState blk))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (WithFingerprint (PerasCertDbState blk))
pcdbState ((PerasCertDbState blk -> PerasCertDbState blk)
-> WithFingerprint (PerasCertDbState blk)
-> WithFingerprint (PerasCertDbState blk)
forall a b. (a -> b) -> WithFingerprint a -> WithFingerprint b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PerasCertDbState blk -> PerasCertDbState blk
gc)
  m () -> STM m (m ())
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m () -> STM m (m ())) -> m () -> STM m (m ())
forall a b. (a -> b) -> a -> b
$ Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
pcdbTracer (SlotNo -> TraceEvent blk
forall blk. SlotNo -> TraceEvent blk
GarbageCollected SlotNo
slotNo)
 where
  gc :: PerasCertDbState blk -> PerasCertDbState blk
  gc :: PerasCertDbState blk -> PerasCertDbState blk
gc
    PerasCertDbState
      { Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
pcdsCertsByTicket :: forall blk.
PerasCertDbState blk
-> Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
pcdsCertsByTicket :: Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
pcdsCertsByTicket
      , PerasCertTicketNo
pcdsLastTicketNo :: forall blk. PerasCertDbState blk -> PerasCertTicketNo
pcdsLastTicketNo :: PerasCertTicketNo
pcdsLastTicketNo
      , Maybe (WithArrivalTime (ValidatedPerasCert blk))
pcdsLatestCertSeen :: forall blk.
PerasCertDbState blk
-> Maybe (WithArrivalTime (ValidatedPerasCert blk))
pcdsLatestCertSeen :: Maybe (WithArrivalTime (ValidatedPerasCert blk))
pcdsLatestCertSeen
      } =
      let pcdsCertsByTicket' :: Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
pcdsCertsByTicket' =
            (WithArrivalTime (ValidatedPerasCert blk) -> Bool)
-> Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
-> Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter
              (\WithArrivalTime (ValidatedPerasCert blk)
cert -> Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot (WithArrivalTime (ValidatedPerasCert blk) -> Point blk
forall cert blk.
HasPerasCertBoostedBlock cert blk =>
cert -> Point blk
getPerasCertBoostedBlock WithArrivalTime (ValidatedPerasCert blk)
cert) WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
slotNo)
              Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
pcdsCertsByTicket
          pcdsCertIds' :: Set PerasRoundNo
pcdsCertIds' =
            [PerasRoundNo] -> Set PerasRoundNo
forall a. Ord a => [a] -> Set a
Set.fromList (WithArrivalTime (ValidatedPerasCert blk) -> PerasRoundNo
forall cert. HasPerasCertRound cert => cert -> PerasRoundNo
getPerasCertRound (WithArrivalTime (ValidatedPerasCert blk) -> PerasRoundNo)
-> [WithArrivalTime (ValidatedPerasCert blk)] -> [PerasRoundNo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
-> [WithArrivalTime (ValidatedPerasCert blk)]
forall k a. Map k a -> [a]
Map.elems Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
pcdsCertsByTicket')
       in PerasCertDbState
            { pcdsCertIds :: Set PerasRoundNo
pcdsCertIds = Set PerasRoundNo
pcdsCertIds'
            , pcdsCertsByTicket :: Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
pcdsCertsByTicket = Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))
pcdsCertsByTicket'
            , pcdsLastTicketNo :: PerasCertTicketNo
pcdsLastTicketNo = PerasCertTicketNo
pcdsLastTicketNo
            , pcdsLatestCertSeen :: Maybe (WithArrivalTime (ValidatedPerasCert blk))
pcdsLatestCertSeen = Maybe (WithArrivalTime (ValidatedPerasCert blk))
pcdsLatestCertSeen
            }