{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}

module Ouroboros.Consensus.Storage.PerasVoteDB.Impl
  ( -- * Opening
    PerasVoteDbArgs (..)
  , defaultArgs
  , createDB

    -- * Trace types
  , TraceEvent (..)

    -- * Exceptions
  , ExistingPerasRoundWinner (..)
  , BlockedPerasRoundWinner (..)
  , PerasVoteDbError (..)
  ) where

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

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

data PerasVoteDbEnv m blk = PerasVoteDbEnv
  { forall (m :: * -> *) blk.
PerasVoteDbEnv m blk -> Tracer m (TraceEvent blk)
pvdeTracer :: !(Tracer m (TraceEvent blk))
  , forall (m :: * -> *) blk.
PerasVoteDbEnv m blk
-> StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState :: !(StrictTVar m (WithFingerprint (PerasVoteDbState blk)))
  -- ^ The 'RoundNo's of all votes currently in the db.
  }
  deriving Context -> PerasVoteDbEnv m blk -> IO (Maybe ThunkInfo)
Proxy (PerasVoteDbEnv m blk) -> String
(Context -> PerasVoteDbEnv m blk -> IO (Maybe ThunkInfo))
-> (Context -> PerasVoteDbEnv m blk -> IO (Maybe ThunkInfo))
-> (Proxy (PerasVoteDbEnv m blk) -> String)
-> NoThunks (PerasVoteDbEnv m blk)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (m :: * -> *) blk.
Context -> PerasVoteDbEnv m blk -> IO (Maybe ThunkInfo)
forall (m :: * -> *) blk. Proxy (PerasVoteDbEnv m blk) -> String
$cnoThunks :: forall (m :: * -> *) blk.
Context -> PerasVoteDbEnv m blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> PerasVoteDbEnv m blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *) blk.
Context -> PerasVoteDbEnv m blk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PerasVoteDbEnv m blk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (m :: * -> *) blk. Proxy (PerasVoteDbEnv m blk) -> String
showTypeOf :: Proxy (PerasVoteDbEnv m blk) -> String
NoThunks via OnlyCheckWhnfNamed "PerasVoteDbEnv" (PerasVoteDbEnv m blk)

-- INVARIANT: See 'invariantForPerasVoteDbState'.
data PerasVoteDbState blk = PerasVoteDbState
  { forall blk. PerasVoteDbState blk -> Set (PerasVoteId blk)
pvdsVoteIds :: !(Set (PerasVoteId blk))
  , forall blk.
PerasVoteDbState blk -> Map PerasRoundNo (PerasRoundVoteState blk)
pvdsRoundVoteStates :: !(Map PerasRoundNo (PerasRoundVoteState blk))
  , forall blk.
PerasVoteDbState blk
-> Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
pvdsVotesByTicket :: !(Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk)))
  -- ^ The votes by 'PerasVoteTicketNo'.
  --
  -- INVARIANT: In sync with 'pvsRoundVoteStates'.
  , forall blk. PerasVoteDbState blk -> PerasVoteTicketNo
pvdsLastTicketNo :: !PerasVoteTicketNo
  -- ^ The most recent 'PerasVoteTicketNo' (or 'zeroPerasVoteTicketNo' otherwise).
  }
  deriving stock (Int -> PerasVoteDbState blk -> ShowS
[PerasVoteDbState blk] -> ShowS
PerasVoteDbState blk -> String
(Int -> PerasVoteDbState blk -> ShowS)
-> (PerasVoteDbState blk -> String)
-> ([PerasVoteDbState blk] -> ShowS)
-> Show (PerasVoteDbState blk)
forall blk.
StandardHash blk =>
Int -> PerasVoteDbState blk -> ShowS
forall blk. StandardHash blk => [PerasVoteDbState blk] -> ShowS
forall blk. StandardHash blk => PerasVoteDbState blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk.
StandardHash blk =>
Int -> PerasVoteDbState blk -> ShowS
showsPrec :: Int -> PerasVoteDbState blk -> ShowS
$cshow :: forall blk. StandardHash blk => PerasVoteDbState blk -> String
show :: PerasVoteDbState blk -> String
$cshowList :: forall blk. StandardHash blk => [PerasVoteDbState blk] -> ShowS
showList :: [PerasVoteDbState blk] -> ShowS
Show, (forall x. PerasVoteDbState blk -> Rep (PerasVoteDbState blk) x)
-> (forall x. Rep (PerasVoteDbState blk) x -> PerasVoteDbState blk)
-> Generic (PerasVoteDbState blk)
forall x. Rep (PerasVoteDbState blk) x -> PerasVoteDbState blk
forall x. PerasVoteDbState blk -> Rep (PerasVoteDbState blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (PerasVoteDbState blk) x -> PerasVoteDbState blk
forall blk x. PerasVoteDbState blk -> Rep (PerasVoteDbState blk) x
$cfrom :: forall blk x. PerasVoteDbState blk -> Rep (PerasVoteDbState blk) x
from :: forall x. PerasVoteDbState blk -> Rep (PerasVoteDbState blk) x
$cto :: forall blk x. Rep (PerasVoteDbState blk) x -> PerasVoteDbState blk
to :: forall x. Rep (PerasVoteDbState blk) x -> PerasVoteDbState blk
Generic)
  deriving anyclass Context -> PerasVoteDbState blk -> IO (Maybe ThunkInfo)
Proxy (PerasVoteDbState blk) -> String
(Context -> PerasVoteDbState blk -> IO (Maybe ThunkInfo))
-> (Context -> PerasVoteDbState blk -> IO (Maybe ThunkInfo))
-> (Proxy (PerasVoteDbState blk) -> String)
-> NoThunks (PerasVoteDbState blk)
forall blk.
StandardHash blk =>
Context -> PerasVoteDbState blk -> IO (Maybe ThunkInfo)
forall blk.
StandardHash blk =>
Proxy (PerasVoteDbState 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 -> PerasVoteDbState blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> PerasVoteDbState blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk.
StandardHash blk =>
Context -> PerasVoteDbState blk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PerasVoteDbState blk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall blk.
StandardHash blk =>
Proxy (PerasVoteDbState blk) -> String
showTypeOf :: Proxy (PerasVoteDbState blk) -> String
NoThunks

initialPerasVoteDbState :: WithFingerprint (PerasVoteDbState blk)
initialPerasVoteDbState :: forall blk. WithFingerprint (PerasVoteDbState blk)
initialPerasVoteDbState =
  PerasVoteDbState blk
-> Fingerprint -> WithFingerprint (PerasVoteDbState blk)
forall a. a -> Fingerprint -> WithFingerprint a
WithFingerprint
    PerasVoteDbState
      { pvdsVoteIds :: Set (PerasVoteId blk)
pvdsVoteIds = Set (PerasVoteId blk)
forall a. Set a
Set.empty
      , pvdsRoundVoteStates :: Map PerasRoundNo (PerasRoundVoteState blk)
pvdsRoundVoteStates = Map PerasRoundNo (PerasRoundVoteState blk)
forall k a. Map k a
Map.empty
      , pvdsVotesByTicket :: Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
pvdsVotesByTicket = Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
forall k a. Map k a
Map.empty
      , pvdsLastTicketNo :: PerasVoteTicketNo
pvdsLastTicketNo = PerasVoteTicketNo
zeroPerasVoteTicketNo
      }
    (Word64 -> Fingerprint
Fingerprint Word64
0)

-- | Check that the fields of 'PerasVoteState' are in sync.
invariantForPerasVoteDbState ::
  WithFingerprint (PerasVoteDbState blk) -> Either String ()
invariantForPerasVoteDbState :: forall blk.
WithFingerprint (PerasVoteDbState blk) -> Either String ()
invariantForPerasVoteDbState WithFingerprint (PerasVoteDbState blk)
pvs = do
  [(PerasRoundNo, PerasRoundVoteState blk)]
-> ((PerasRoundNo, PerasRoundVoteState blk) -> Either String ())
-> Either String ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Map PerasRoundNo (PerasRoundVoteState blk)
-> [(PerasRoundNo, PerasRoundVoteState blk)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PerasRoundNo (PerasRoundVoteState blk)
pvdsRoundVoteStates) (((PerasRoundNo, PerasRoundVoteState blk) -> Either String ())
 -> Either String ())
-> ((PerasRoundNo, PerasRoundVoteState blk) -> Either String ())
-> Either String ()
forall a b. (a -> b) -> a -> b
$ \(PerasRoundNo
roundNo, PerasRoundVoteState blk
prvs) ->
    String -> PerasRoundNo -> PerasRoundNo -> Either String ()
forall a. (Eq a, Show a) => String -> a -> a -> Either String ()
checkEqual String
"pvcRoundVoteStates rounds" PerasRoundNo
roundNo (PerasRoundVoteState blk -> PerasRoundNo
forall vote. HasPerasVoteRound vote => vote -> PerasRoundNo
getPerasVoteRound PerasRoundVoteState blk
prvs)
  String -> Set PerasRoundNo -> Set PerasRoundNo -> Either String ()
forall a. (Eq a, Show a) => String -> a -> a -> Either String ()
checkEqual
    String
"pvcsVotesByTicket"
    ([PerasRoundNo] -> Set PerasRoundNo
forall a. Ord a => [a] -> Set a
Set.fromList (WithArrivalTime (ValidatedPerasVote blk) -> PerasRoundNo
forall vote. HasPerasVoteRound vote => vote -> PerasRoundNo
getPerasVoteRound (WithArrivalTime (ValidatedPerasVote blk) -> PerasRoundNo)
-> [WithArrivalTime (ValidatedPerasVote blk)] -> [PerasRoundNo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
-> [WithArrivalTime (ValidatedPerasVote blk)]
forall k a. Map k a -> [a]
Map.elems Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
pvdsVotesByTicket))
    ([PerasRoundNo] -> Set PerasRoundNo
forall a. Ord a => [a] -> Set a
Set.fromList (PerasVoteId blk -> PerasRoundNo
forall blk. PerasVoteId blk -> PerasRoundNo
pviRoundNo (PerasVoteId blk -> PerasRoundNo)
-> [PerasVoteId blk] -> [PerasRoundNo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set (PerasVoteId blk) -> [PerasVoteId blk]
forall a. Set a -> [a]
Set.elems Set (PerasVoteId blk)
pvdsVoteIds))
  [PerasVoteTicketNo]
-> (PerasVoteTicketNo -> Either String ()) -> Either String ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
-> [PerasVoteTicketNo]
forall k a. Map k a -> [k]
Map.keys Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
pvdsVotesByTicket) ((PerasVoteTicketNo -> Either String ()) -> Either String ())
-> (PerasVoteTicketNo -> Either String ()) -> Either String ()
forall a b. (a -> b) -> a -> b
$ \PerasVoteTicketNo
ticketNo ->
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PerasVoteTicketNo
ticketNo PerasVoteTicketNo -> PerasVoteTicketNo -> Bool
forall a. Ord a => a -> a -> Bool
> PerasVoteTicketNo
pvdsLastTicketNo) (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
<> PerasVoteTicketNo -> String
forall a. Show a => a -> String
show PerasVoteTicketNo
ticketNo
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" > "
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PerasVoteTicketNo -> String
forall a. Show a => a -> String
show PerasVoteTicketNo
pvdsLastTicketNo
 where
  PerasVoteDbState
    { Map PerasRoundNo (PerasRoundVoteState blk)
pvdsRoundVoteStates :: forall blk.
PerasVoteDbState blk -> Map PerasRoundNo (PerasRoundVoteState blk)
pvdsRoundVoteStates :: Map PerasRoundNo (PerasRoundVoteState blk)
pvdsRoundVoteStates
    , Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
pvdsVotesByTicket :: forall blk.
PerasVoteDbState blk
-> Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
pvdsVotesByTicket :: Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
pvdsVotesByTicket
    , Set (PerasVoteId blk)
pvdsVoteIds :: forall blk. PerasVoteDbState blk -> Set (PerasVoteId blk)
pvdsVoteIds :: Set (PerasVoteId blk)
pvdsVoteIds
    , PerasVoteTicketNo
pvdsLastTicketNo :: forall blk. PerasVoteDbState blk -> PerasVoteTicketNo
pvdsLastTicketNo :: PerasVoteTicketNo
pvdsLastTicketNo
    } = WithFingerprint (PerasVoteDbState blk) -> PerasVoteDbState blk
forall a. WithFingerprint a -> a
forgetFingerprint WithFingerprint (PerasVoteDbState blk)
pvs

  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
  = AddVote
      (PerasVoteId blk)
      (WithArrivalTime (ValidatedPerasVote blk))
      (AddPerasVoteResult blk)
  | GarbageCollected
      PerasRoundNo
  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)

{-------------------------------------------------------------------------------
  Exceptions
-------------------------------------------------------------------------------}

newtype ExistingPerasRoundWinner blk
  = ExistingPerasRoundWinner (Point blk, PerasVoteStake)
  deriving stock (Int -> ExistingPerasRoundWinner blk -> ShowS
[ExistingPerasRoundWinner blk] -> ShowS
ExistingPerasRoundWinner blk -> String
(Int -> ExistingPerasRoundWinner blk -> ShowS)
-> (ExistingPerasRoundWinner blk -> String)
-> ([ExistingPerasRoundWinner blk] -> ShowS)
-> Show (ExistingPerasRoundWinner blk)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (blk :: k).
StandardHash blk =>
Int -> ExistingPerasRoundWinner blk -> ShowS
forall k (blk :: k).
StandardHash blk =>
[ExistingPerasRoundWinner blk] -> ShowS
forall k (blk :: k).
StandardHash blk =>
ExistingPerasRoundWinner blk -> String
$cshowsPrec :: forall k (blk :: k).
StandardHash blk =>
Int -> ExistingPerasRoundWinner blk -> ShowS
showsPrec :: Int -> ExistingPerasRoundWinner blk -> ShowS
$cshow :: forall k (blk :: k).
StandardHash blk =>
ExistingPerasRoundWinner blk -> String
show :: ExistingPerasRoundWinner blk -> String
$cshowList :: forall k (blk :: k).
StandardHash blk =>
[ExistingPerasRoundWinner blk] -> ShowS
showList :: [ExistingPerasRoundWinner blk] -> ShowS
Show, ExistingPerasRoundWinner blk
-> ExistingPerasRoundWinner blk -> Bool
(ExistingPerasRoundWinner blk
 -> ExistingPerasRoundWinner blk -> Bool)
-> (ExistingPerasRoundWinner blk
    -> ExistingPerasRoundWinner blk -> Bool)
-> Eq (ExistingPerasRoundWinner blk)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (blk :: k).
StandardHash blk =>
ExistingPerasRoundWinner blk
-> ExistingPerasRoundWinner blk -> Bool
$c== :: forall k (blk :: k).
StandardHash blk =>
ExistingPerasRoundWinner blk
-> ExistingPerasRoundWinner blk -> Bool
== :: ExistingPerasRoundWinner blk
-> ExistingPerasRoundWinner blk -> Bool
$c/= :: forall k (blk :: k).
StandardHash blk =>
ExistingPerasRoundWinner blk
-> ExistingPerasRoundWinner blk -> Bool
/= :: ExistingPerasRoundWinner blk
-> ExistingPerasRoundWinner blk -> Bool
Eq)

newtype BlockedPerasRoundWinner blk
  = BlockedPerasRoundWinner (Point blk, PerasVoteStake)
  deriving stock (Int -> BlockedPerasRoundWinner blk -> ShowS
[BlockedPerasRoundWinner blk] -> ShowS
BlockedPerasRoundWinner blk -> String
(Int -> BlockedPerasRoundWinner blk -> ShowS)
-> (BlockedPerasRoundWinner blk -> String)
-> ([BlockedPerasRoundWinner blk] -> ShowS)
-> Show (BlockedPerasRoundWinner blk)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (blk :: k).
StandardHash blk =>
Int -> BlockedPerasRoundWinner blk -> ShowS
forall k (blk :: k).
StandardHash blk =>
[BlockedPerasRoundWinner blk] -> ShowS
forall k (blk :: k).
StandardHash blk =>
BlockedPerasRoundWinner blk -> String
$cshowsPrec :: forall k (blk :: k).
StandardHash blk =>
Int -> BlockedPerasRoundWinner blk -> ShowS
showsPrec :: Int -> BlockedPerasRoundWinner blk -> ShowS
$cshow :: forall k (blk :: k).
StandardHash blk =>
BlockedPerasRoundWinner blk -> String
show :: BlockedPerasRoundWinner blk -> String
$cshowList :: forall k (blk :: k).
StandardHash blk =>
[BlockedPerasRoundWinner blk] -> ShowS
showList :: [BlockedPerasRoundWinner blk] -> ShowS
Show, BlockedPerasRoundWinner blk -> BlockedPerasRoundWinner blk -> Bool
(BlockedPerasRoundWinner blk
 -> BlockedPerasRoundWinner blk -> Bool)
-> (BlockedPerasRoundWinner blk
    -> BlockedPerasRoundWinner blk -> Bool)
-> Eq (BlockedPerasRoundWinner blk)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (blk :: k).
StandardHash blk =>
BlockedPerasRoundWinner blk -> BlockedPerasRoundWinner blk -> Bool
$c== :: forall k (blk :: k).
StandardHash blk =>
BlockedPerasRoundWinner blk -> BlockedPerasRoundWinner blk -> Bool
== :: BlockedPerasRoundWinner blk -> BlockedPerasRoundWinner blk -> Bool
$c/= :: forall k (blk :: k).
StandardHash blk =>
BlockedPerasRoundWinner blk -> BlockedPerasRoundWinner blk -> Bool
/= :: BlockedPerasRoundWinner blk -> BlockedPerasRoundWinner blk -> Bool
Eq)

data PerasVoteDbError blk
  = -- | Attempted to add a vote that would lead to multiple winners for the
    -- same round
    MultipleWinnersInRound
      PerasRoundNo
      (ExistingPerasRoundWinner blk)
      (BlockedPerasRoundWinner blk)
  | -- | An error occurred while forging a certificate
    ForgingCertError (PerasForgeErr blk)
  deriving stock Int -> PerasVoteDbError blk -> ShowS
[PerasVoteDbError blk] -> ShowS
PerasVoteDbError blk -> String
(Int -> PerasVoteDbError blk -> ShowS)
-> (PerasVoteDbError blk -> String)
-> ([PerasVoteDbError blk] -> ShowS)
-> Show (PerasVoteDbError blk)
forall blk.
StandardHash blk =>
Int -> PerasVoteDbError blk -> ShowS
forall blk. StandardHash blk => [PerasVoteDbError blk] -> ShowS
forall blk. StandardHash blk => PerasVoteDbError blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk.
StandardHash blk =>
Int -> PerasVoteDbError blk -> ShowS
showsPrec :: Int -> PerasVoteDbError blk -> ShowS
$cshow :: forall blk. StandardHash blk => PerasVoteDbError blk -> String
show :: PerasVoteDbError blk -> String
$cshowList :: forall blk. StandardHash blk => [PerasVoteDbError blk] -> ShowS
showList :: [PerasVoteDbError blk] -> ShowS
Show
  deriving anyclass Show (PerasVoteDbError blk)
Typeable (PerasVoteDbError blk)
(Typeable (PerasVoteDbError blk), Show (PerasVoteDbError blk)) =>
(PerasVoteDbError blk -> SomeException)
-> (SomeException -> Maybe (PerasVoteDbError blk))
-> (PerasVoteDbError blk -> String)
-> (PerasVoteDbError blk -> Bool)
-> Exception (PerasVoteDbError blk)
SomeException -> Maybe (PerasVoteDbError blk)
PerasVoteDbError blk -> Bool
PerasVoteDbError blk -> String
PerasVoteDbError blk -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
forall blk.
(StandardHash blk, Typeable blk) =>
Show (PerasVoteDbError blk)
forall blk.
(StandardHash blk, Typeable blk) =>
Typeable (PerasVoteDbError blk)
forall blk.
(StandardHash blk, Typeable blk) =>
SomeException -> Maybe (PerasVoteDbError blk)
forall blk.
(StandardHash blk, Typeable blk) =>
PerasVoteDbError blk -> Bool
forall blk.
(StandardHash blk, Typeable blk) =>
PerasVoteDbError blk -> String
forall blk.
(StandardHash blk, Typeable blk) =>
PerasVoteDbError blk -> SomeException
$ctoException :: forall blk.
(StandardHash blk, Typeable blk) =>
PerasVoteDbError blk -> SomeException
toException :: PerasVoteDbError blk -> SomeException
$cfromException :: forall blk.
(StandardHash blk, Typeable blk) =>
SomeException -> Maybe (PerasVoteDbError blk)
fromException :: SomeException -> Maybe (PerasVoteDbError blk)
$cdisplayException :: forall blk.
(StandardHash blk, Typeable blk) =>
PerasVoteDbError blk -> String
displayException :: PerasVoteDbError blk -> String
$cbacktraceDesired :: forall blk.
(StandardHash blk, Typeable blk) =>
PerasVoteDbError blk -> Bool
backtraceDesired :: PerasVoteDbError blk -> Bool
Exception

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

type PerasVoteDbArgs :: (Type -> Type) -> (Type -> Type) -> Type -> Type
data PerasVoteDbArgs f m blk = PerasVoteDbArgs
  { forall (f :: * -> *) (m :: * -> *) blk.
PerasVoteDbArgs f m blk -> Tracer m (TraceEvent blk)
pvdbaTracer :: Tracer m (TraceEvent blk)
  , forall (f :: * -> *) (m :: * -> *) blk.
PerasVoteDbArgs f m blk -> HKD f (PerasCfg blk)
pvdbaPerasCfg :: HKD f (PerasCfg blk)
  }

defaultArgs :: Applicative m => Incomplete PerasVoteDbArgs m blk
defaultArgs :: forall (m :: * -> *) blk.
Applicative m =>
Incomplete PerasVoteDbArgs m blk
defaultArgs =
  PerasVoteDbArgs
    { pvdbaTracer :: Tracer m (TraceEvent blk)
pvdbaTracer = Tracer m (TraceEvent blk)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , pvdbaPerasCfg :: HKD Defaults (PerasCfg blk)
pvdbaPerasCfg = HKD Defaults (PerasCfg blk)
Defaults PerasParams
forall {k} (t :: k). Defaults t
noDefault
    }

createDB ::
  forall m blk.
  ( IOLike m
  , StandardHash blk
  , Typeable blk
  ) =>
  Complete PerasVoteDbArgs m blk ->
  m (PerasVoteDB m blk)
createDB :: forall (m :: * -> *) blk.
(IOLike m, StandardHash blk, Typeable blk) =>
Complete PerasVoteDbArgs m blk -> m (PerasVoteDB m blk)
createDB args :: Complete PerasVoteDbArgs m blk
args@PerasVoteDbArgs{HKD Identity (PerasCfg blk)
pvdbaPerasCfg :: forall (f :: * -> *) (m :: * -> *) blk.
PerasVoteDbArgs f m blk -> HKD f (PerasCfg blk)
pvdbaPerasCfg :: HKD Identity (PerasCfg blk)
pvdbaPerasCfg} = do
  pvdeState <-
    (WithFingerprint (PerasVoteDbState blk) -> Maybe String)
-> WithFingerprint (PerasVoteDbState blk)
-> m (StrictTVar m (WithFingerprint (PerasVoteDbState 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 (PerasVoteDbState blk) -> Either String ())
-> WithFingerprint (PerasVoteDbState blk)
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithFingerprint (PerasVoteDbState blk) -> Either String ()
forall blk.
WithFingerprint (PerasVoteDbState blk) -> Either String ()
invariantForPerasVoteDbState)
      WithFingerprint (PerasVoteDbState blk)
forall blk. WithFingerprint (PerasVoteDbState blk)
initialPerasVoteDbState
  let env =
        PerasVoteDbEnv
          { Tracer m (TraceEvent blk)
pvdeTracer :: Tracer m (TraceEvent blk)
pvdeTracer :: Tracer m (TraceEvent blk)
pvdeTracer
          , StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState :: StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState :: StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState
          }
  pure
    PerasVoteDB
      { addVote = implAddVote pvdbaPerasCfg env
      , getVoteIds = implGetVoteIds env
      , getVotesAfter = implGetVotesAfter env
      , getForgedCertForRound = implGetForgedCertForRound env
      , garbageCollect = implGarbageCollect env
      }
 where
  PerasVoteDbArgs
    { pvdbaTracer :: forall (f :: * -> *) (m :: * -> *) blk.
PerasVoteDbArgs f m blk -> Tracer m (TraceEvent blk)
pvdbaTracer = Tracer m (TraceEvent blk)
pvdeTracer
    } = Complete PerasVoteDbArgs 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
implAddVote ::
  ( IOLike m
  , StandardHash blk
  , Typeable blk
  ) =>
  PerasCfg blk ->
  PerasVoteDbEnv m blk ->
  WithArrivalTime (ValidatedPerasVote blk) ->
  STM m (m (AddPerasVoteResult blk))
implAddVote :: forall (m :: * -> *) blk.
(IOLike m, StandardHash blk, Typeable blk) =>
PerasCfg blk
-> PerasVoteDbEnv m blk
-> WithArrivalTime (ValidatedPerasVote blk)
-> STM m (m (AddPerasVoteResult blk))
implAddVote PerasCfg blk
perasCfg PerasVoteDbEnv{Tracer m (TraceEvent blk)
pvdeTracer :: forall (m :: * -> *) blk.
PerasVoteDbEnv m blk -> Tracer m (TraceEvent blk)
pvdeTracer :: Tracer m (TraceEvent blk)
pvdeTracer, StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState :: forall (m :: * -> *) blk.
PerasVoteDbEnv m blk
-> StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState :: StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState} WithArrivalTime (ValidatedPerasVote blk)
vote = do
  let voteId :: PerasVoteId blk
voteId = WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteId blk
forall vote blk. HasPerasVoteId vote blk => vote -> PerasVoteId blk
getPerasVoteId WithArrivalTime (ValidatedPerasVote blk)
vote
  addPerasVoteRes <- do
    WithFingerprint pvds fp <- StrictTVar m (WithFingerprint (PerasVoteDbState blk))
-> STM m (WithFingerprint (PerasVoteDbState blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState
    (res, pvds') <- addOrIgnoreVote pvds voteId
    writeTVar pvdeState (WithFingerprint pvds' (succ fp))
    pure res
  pure $ do
    traceWith pvdeTracer (AddVote voteId vote addPerasVoteRes)
    return addPerasVoteRes
 where
  addOrIgnoreVote :: PerasVoteDbState blk
-> PerasVoteId blk
-> STM m (AddPerasVoteResult blk, PerasVoteDbState blk)
addOrIgnoreVote PerasVoteDbState blk
pvds PerasVoteId blk
voteId
    -- Vote is already in the DB => ignore it
    | PerasVoteId blk -> Set (PerasVoteId blk) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member PerasVoteId blk
voteId (PerasVoteDbState blk -> Set (PerasVoteId blk)
forall blk. PerasVoteDbState blk -> Set (PerasVoteId blk)
pvdsVoteIds PerasVoteDbState blk
pvds) = PerasVoteDbState blk
-> STM m (AddPerasVoteResult blk, PerasVoteDbState blk)
forall {f :: * -> *} {b} {blk}.
Applicative f =>
b -> f (AddPerasVoteResult blk, b)
voteAlreadyInDB PerasVoteDbState blk
pvds
    -- New vote => try to add it to the DB
    | Bool
otherwise = PerasVoteDbState blk
-> PerasVoteId blk
-> STM m (AddPerasVoteResult blk, PerasVoteDbState blk)
tryAddVote PerasVoteDbState blk
pvds PerasVoteId blk
voteId

  voteAlreadyInDB :: b -> f (AddPerasVoteResult blk, b)
voteAlreadyInDB b
pvds = (AddPerasVoteResult blk, b) -> f (AddPerasVoteResult blk, b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AddPerasVoteResult blk
forall blk. AddPerasVoteResult blk
PerasVoteAlreadyInDB, b
pvds)

  tryAddVote :: PerasVoteDbState blk
-> PerasVoteId blk
-> STM m (AddPerasVoteResult blk, PerasVoteDbState blk)
tryAddVote PerasVoteDbState blk
pvds PerasVoteId blk
voteId = do
    let pvsVoteIds' :: Set (PerasVoteId blk)
pvsVoteIds' = PerasVoteId blk -> Set (PerasVoteId blk) -> Set (PerasVoteId blk)
forall a. Ord a => a -> Set a -> Set a
Set.insert PerasVoteId blk
voteId (PerasVoteDbState blk -> Set (PerasVoteId blk)
forall blk. PerasVoteDbState blk -> Set (PerasVoteId blk)
pvdsVoteIds PerasVoteDbState blk
pvds)
        pvsLastTicketNo' :: PerasVoteTicketNo
pvsLastTicketNo' = PerasVoteTicketNo -> PerasVoteTicketNo
forall a. Enum a => a -> a
succ (PerasVoteDbState blk -> PerasVoteTicketNo
forall blk. PerasVoteDbState blk -> PerasVoteTicketNo
pvdsLastTicketNo PerasVoteDbState blk
pvds)
        pvsVotesByTicket' :: Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
pvsVotesByTicket' = PerasVoteTicketNo
-> WithArrivalTime (ValidatedPerasVote blk)
-> Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
-> Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PerasVoteTicketNo
pvsLastTicketNo' WithArrivalTime (ValidatedPerasVote blk)
vote (PerasVoteDbState blk
-> Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
forall blk.
PerasVoteDbState blk
-> Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
pvdsVotesByTicket PerasVoteDbState blk
pvds)

    (addPerasVoteRes, pvsRoundVoteStates') <-
      case WithArrivalTime (ValidatedPerasVote blk)
-> PerasCfg blk
-> Map PerasRoundNo (PerasRoundVoteState blk)
-> Either
     (UpdateRoundVoteStateError blk)
     (PerasRoundVoteState blk,
      Map PerasRoundNo (PerasRoundVoteState blk))
forall blk.
StandardHash blk =>
WithArrivalTime (ValidatedPerasVote blk)
-> PerasCfg blk
-> Map PerasRoundNo (PerasRoundVoteState blk)
-> Either
     (UpdateRoundVoteStateError blk)
     (PerasRoundVoteState blk,
      Map PerasRoundNo (PerasRoundVoteState blk))
updatePerasRoundVoteStates WithArrivalTime (ValidatedPerasVote blk)
vote PerasCfg blk
perasCfg (PerasVoteDbState blk -> Map PerasRoundNo (PerasRoundVoteState blk)
forall blk.
PerasVoteDbState blk -> Map PerasRoundNo (PerasRoundVoteState blk)
pvdsRoundVoteStates PerasVoteDbState blk
pvds) of
        -- Added vote and reached a quorum, forging a new certificate
        Right (VoteGeneratedNewCert ValidatedPerasCert blk
cert, Map PerasRoundNo (PerasRoundVoteState blk)
pvsRoundVoteStates') ->
          (AddPerasVoteResult blk,
 Map PerasRoundNo (PerasRoundVoteState blk))
-> STM
     m
     (AddPerasVoteResult blk,
      Map PerasRoundNo (PerasRoundVoteState blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValidatedPerasCert blk -> AddPerasVoteResult blk
forall blk. ValidatedPerasCert blk -> AddPerasVoteResult blk
AddedPerasVoteAndGeneratedNewCert ValidatedPerasCert blk
cert, Map PerasRoundNo (PerasRoundVoteState blk)
pvsRoundVoteStates')
        -- Added vote but did not generate a new certificate, either
        -- because quorum was not reached yet, or because this vote was
        -- cast upon a target that had already won so a certificate was
        -- forged in a previous step.
        Right (PerasRoundVoteState blk
VoteDidntGenerateNewCert, Map PerasRoundNo (PerasRoundVoteState blk)
pvsRoundVoteStates') ->
          (AddPerasVoteResult blk,
 Map PerasRoundNo (PerasRoundVoteState blk))
-> STM
     m
     (AddPerasVoteResult blk,
      Map PerasRoundNo (PerasRoundVoteState blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AddPerasVoteResult blk
forall blk. AddPerasVoteResult blk
AddedPerasVoteButDidntGenerateNewCert, Map PerasRoundNo (PerasRoundVoteState blk)
pvsRoundVoteStates')
        -- Adding the vote led to more than one winner => internal error
        Left (RoundVoteStateLoserAboveQuorum PerasTargetVoteState blk 'Winner
winnerState PerasTargetVoteState blk 'Loser
loserState) ->
          PerasVoteDbError blk
-> STM
     m
     (AddPerasVoteResult blk,
      Map PerasRoundNo (PerasRoundVoteState blk))
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (PerasVoteDbError blk
 -> STM
      m
      (AddPerasVoteResult blk,
       Map PerasRoundNo (PerasRoundVoteState blk)))
-> PerasVoteDbError blk
-> STM
     m
     (AddPerasVoteResult blk,
      Map PerasRoundNo (PerasRoundVoteState blk))
forall a b. (a -> b) -> a -> b
$
            PerasRoundNo
-> ExistingPerasRoundWinner blk
-> BlockedPerasRoundWinner blk
-> PerasVoteDbError blk
forall blk.
PerasRoundNo
-> ExistingPerasRoundWinner blk
-> BlockedPerasRoundWinner blk
-> PerasVoteDbError blk
MultipleWinnersInRound
              (WithArrivalTime (ValidatedPerasVote blk) -> PerasRoundNo
forall vote. HasPerasVoteRound vote => vote -> PerasRoundNo
getPerasVoteRound WithArrivalTime (ValidatedPerasVote blk)
vote)
              ( (Point blk, PerasVoteStake) -> ExistingPerasRoundWinner blk
forall {k} (blk :: k).
(Point blk, PerasVoteStake) -> ExistingPerasRoundWinner blk
ExistingPerasRoundWinner
                  ( PerasTargetVoteState blk 'Winner -> Point blk
forall vote blk. HasPerasVoteBlock vote blk => vote -> Point blk
getPerasVoteBlock PerasTargetVoteState blk 'Winner
winnerState
                  , PerasTargetVoteState blk 'Winner -> PerasVoteStake
forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasVoteStake
ptvsTotalStake PerasTargetVoteState blk 'Winner
winnerState
                  )
              )
              ( (Point blk, PerasVoteStake) -> BlockedPerasRoundWinner blk
forall {k} (blk :: k).
(Point blk, PerasVoteStake) -> BlockedPerasRoundWinner blk
BlockedPerasRoundWinner
                  ( PerasTargetVoteState blk 'Loser -> Point blk
forall vote blk. HasPerasVoteBlock vote blk => vote -> Point blk
getPerasVoteBlock PerasTargetVoteState blk 'Loser
loserState
                  , PerasTargetVoteState blk 'Loser -> PerasVoteStake
forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasVoteStake
ptvsTotalStake PerasTargetVoteState blk 'Loser
loserState
                  )
              )
        -- Reached quorum but failed to forge a certificate
        Left (RoundVoteStateForgingCertError PerasForgeErr blk
forgeErr) ->
          PerasVoteDbError blk
-> STM
     m
     (AddPerasVoteResult blk,
      Map PerasRoundNo (PerasRoundVoteState blk))
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (PerasVoteDbError blk
 -> STM
      m
      (AddPerasVoteResult blk,
       Map PerasRoundNo (PerasRoundVoteState blk)))
-> PerasVoteDbError blk
-> STM
     m
     (AddPerasVoteResult blk,
      Map PerasRoundNo (PerasRoundVoteState blk))
forall a b. (a -> b) -> a -> b
$
            PerasForgeErr blk -> PerasVoteDbError blk
forall blk. PerasForgeErr blk -> PerasVoteDbError blk
ForgingCertError PerasForgeErr blk
forgeErr

    pure
      ( addPerasVoteRes
      , PerasVoteDbState
          { pvdsVoteIds = pvsVoteIds'
          , pvdsRoundVoteStates = pvsRoundVoteStates'
          , pvdsVotesByTicket = pvsVotesByTicket'
          , pvdsLastTicketNo = pvsLastTicketNo'
          }
      )

implGetVoteIds ::
  IOLike m =>
  PerasVoteDbEnv m blk ->
  STM m (Set (PerasVoteId blk))
implGetVoteIds :: forall (m :: * -> *) blk.
IOLike m =>
PerasVoteDbEnv m blk -> STM m (Set (PerasVoteId blk))
implGetVoteIds PerasVoteDbEnv{StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState :: forall (m :: * -> *) blk.
PerasVoteDbEnv m blk
-> StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState :: StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState} = do
  PerasVoteDbState{pvdsVoteIds} <-
    WithFingerprint (PerasVoteDbState blk) -> PerasVoteDbState blk
forall a. WithFingerprint a -> a
forgetFingerprint (WithFingerprint (PerasVoteDbState blk) -> PerasVoteDbState blk)
-> STM m (WithFingerprint (PerasVoteDbState blk))
-> STM m (PerasVoteDbState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (WithFingerprint (PerasVoteDbState blk))
-> STM m (WithFingerprint (PerasVoteDbState blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState
  pure pvdsVoteIds

implGetVotesAfter ::
  IOLike m =>
  PerasVoteDbEnv m blk ->
  PerasVoteTicketNo ->
  STM m (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk)))
implGetVotesAfter :: forall (m :: * -> *) blk.
IOLike m =>
PerasVoteDbEnv m blk
-> PerasVoteTicketNo
-> STM
     m
     (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk)))
implGetVotesAfter PerasVoteDbEnv{StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState :: forall (m :: * -> *) blk.
PerasVoteDbEnv m blk
-> StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState :: StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState} PerasVoteTicketNo
ticketNo = do
  PerasVoteDbState{pvdsVotesByTicket} <-
    WithFingerprint (PerasVoteDbState blk) -> PerasVoteDbState blk
forall a. WithFingerprint a -> a
forgetFingerprint (WithFingerprint (PerasVoteDbState blk) -> PerasVoteDbState blk)
-> STM m (WithFingerprint (PerasVoteDbState blk))
-> STM m (PerasVoteDbState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (WithFingerprint (PerasVoteDbState blk))
-> STM m (WithFingerprint (PerasVoteDbState blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState
  pure $ snd $ Map.split ticketNo pvdsVotesByTicket

implGetForgedCertForRound ::
  IOLike m =>
  PerasVoteDbEnv m blk ->
  PerasRoundNo ->
  STM m (Maybe (ValidatedPerasCert blk))
implGetForgedCertForRound :: forall (m :: * -> *) blk.
IOLike m =>
PerasVoteDbEnv m blk
-> PerasRoundNo -> STM m (Maybe (ValidatedPerasCert blk))
implGetForgedCertForRound PerasVoteDbEnv{StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState :: forall (m :: * -> *) blk.
PerasVoteDbEnv m blk
-> StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState :: StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState} PerasRoundNo
roundNo = do
  PerasVoteDbState{pvdsRoundVoteStates} <-
    WithFingerprint (PerasVoteDbState blk) -> PerasVoteDbState blk
forall a. WithFingerprint a -> a
forgetFingerprint (WithFingerprint (PerasVoteDbState blk) -> PerasVoteDbState blk)
-> STM m (WithFingerprint (PerasVoteDbState blk))
-> STM m (PerasVoteDbState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (WithFingerprint (PerasVoteDbState blk))
-> STM m (WithFingerprint (PerasVoteDbState blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState
  case Map.lookup roundNo pvdsRoundVoteStates of
    Maybe (PerasRoundVoteState blk)
Nothing -> Maybe (ValidatedPerasCert blk)
-> STM m (Maybe (ValidatedPerasCert blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ValidatedPerasCert blk)
forall a. Maybe a
Nothing
    Just PerasRoundVoteState blk
aggr -> Maybe (ValidatedPerasCert blk)
-> STM m (Maybe (ValidatedPerasCert blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PerasRoundVoteState blk -> Maybe (ValidatedPerasCert blk)
forall blk.
PerasRoundVoteState blk -> Maybe (ValidatedPerasCert blk)
getPerasRoundVoteStateCertMaybe PerasRoundVoteState blk
aggr)

implGarbageCollect ::
  forall m blk.
  IOLike m =>
  PerasVoteDbEnv m blk ->
  PerasRoundNo ->
  STM m (m ())
implGarbageCollect :: forall (m :: * -> *) blk.
IOLike m =>
PerasVoteDbEnv m blk -> PerasRoundNo -> STM m (m ())
implGarbageCollect PerasVoteDbEnv{Tracer m (TraceEvent blk)
pvdeTracer :: forall (m :: * -> *) blk.
PerasVoteDbEnv m blk -> Tracer m (TraceEvent blk)
pvdeTracer :: Tracer m (TraceEvent blk)
pvdeTracer, StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState :: forall (m :: * -> *) blk.
PerasVoteDbEnv m blk
-> StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState :: StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState} PerasRoundNo
roundNo = do
  -- No need to update the 'Fingerprint' as we only remove votes that do
  -- not matter for comparing interesting chains.
  StrictTVar m (WithFingerprint (PerasVoteDbState blk))
-> (WithFingerprint (PerasVoteDbState blk)
    -> WithFingerprint (PerasVoteDbState blk))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (WithFingerprint (PerasVoteDbState blk))
pvdeState ((PerasVoteDbState blk -> PerasVoteDbState blk)
-> WithFingerprint (PerasVoteDbState blk)
-> WithFingerprint (PerasVoteDbState blk)
forall a b. (a -> b) -> WithFingerprint a -> WithFingerprint b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PerasVoteDbState blk -> PerasVoteDbState 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
$ do
    Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
pvdeTracer (PerasRoundNo -> TraceEvent blk
forall blk. PerasRoundNo -> TraceEvent blk
GarbageCollected PerasRoundNo
roundNo)
    () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
 where
  gc :: PerasVoteDbState blk -> PerasVoteDbState blk
  gc :: PerasVoteDbState blk -> PerasVoteDbState blk
gc
    PerasVoteDbState
      { Set (PerasVoteId blk)
pvdsVoteIds :: forall blk. PerasVoteDbState blk -> Set (PerasVoteId blk)
pvdsVoteIds :: Set (PerasVoteId blk)
pvdsVoteIds
      , Map PerasRoundNo (PerasRoundVoteState blk)
pvdsRoundVoteStates :: forall blk.
PerasVoteDbState blk -> Map PerasRoundNo (PerasRoundVoteState blk)
pvdsRoundVoteStates :: Map PerasRoundNo (PerasRoundVoteState blk)
pvdsRoundVoteStates
      , Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
pvdsVotesByTicket :: forall blk.
PerasVoteDbState blk
-> Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
pvdsVotesByTicket :: Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
pvdsVotesByTicket
      , PerasVoteTicketNo
pvdsLastTicketNo :: forall blk. PerasVoteDbState blk -> PerasVoteTicketNo
pvdsLastTicketNo :: PerasVoteTicketNo
pvdsLastTicketNo
      } =
      let pvsRoundVoteStates' :: Map PerasRoundNo (PerasRoundVoteState blk)
pvsRoundVoteStates' =
            (PerasRoundNo -> PerasRoundVoteState blk -> Bool)
-> Map PerasRoundNo (PerasRoundVoteState blk)
-> Map PerasRoundNo (PerasRoundVoteState blk)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey
              (\PerasRoundNo
rNo PerasRoundVoteState blk
_ -> PerasRoundNo
rNo PerasRoundNo -> PerasRoundNo -> Bool
forall a. Ord a => a -> a -> Bool
>= PerasRoundNo
roundNo)
              Map PerasRoundNo (PerasRoundVoteState blk)
pvdsRoundVoteStates
          (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
pvsVotesByTicket', Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
votesToRemove) =
            (WithArrivalTime (ValidatedPerasVote blk) -> Bool)
-> Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
-> (Map
      PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk)),
    Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk)))
forall a k. (a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partition
              (\WithArrivalTime (ValidatedPerasVote blk)
vote -> WithArrivalTime (ValidatedPerasVote blk) -> PerasRoundNo
forall vote. HasPerasVoteRound vote => vote -> PerasRoundNo
getPerasVoteRound WithArrivalTime (ValidatedPerasVote blk)
vote PerasRoundNo -> PerasRoundNo -> Bool
forall a. Ord a => a -> a -> Bool
>= PerasRoundNo
roundNo)
              Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
pvdsVotesByTicket
          pvsVoteIds' :: Set (PerasVoteId blk)
pvsVoteIds' =
            (Set (PerasVoteId blk)
 -> WithArrivalTime (ValidatedPerasVote blk)
 -> Set (PerasVoteId blk))
-> Set (PerasVoteId blk)
-> Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
-> Set (PerasVoteId blk)
forall b a. (b -> a -> b) -> b -> Map PerasVoteTicketNo a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl'
              (\Set (PerasVoteId blk)
set WithArrivalTime (ValidatedPerasVote blk)
vote -> PerasVoteId blk -> Set (PerasVoteId blk) -> Set (PerasVoteId blk)
forall a. Ord a => a -> Set a -> Set a
Set.delete (WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteId blk
forall vote blk. HasPerasVoteId vote blk => vote -> PerasVoteId blk
getPerasVoteId WithArrivalTime (ValidatedPerasVote blk)
vote) Set (PerasVoteId blk)
set)
              Set (PerasVoteId blk)
pvdsVoteIds
              Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
votesToRemove
       in PerasVoteDbState
            { pvdsVoteIds :: Set (PerasVoteId blk)
pvdsVoteIds = Set (PerasVoteId blk)
pvsVoteIds'
            , pvdsRoundVoteStates :: Map PerasRoundNo (PerasRoundVoteState blk)
pvdsRoundVoteStates = Map PerasRoundNo (PerasRoundVoteState blk)
pvsRoundVoteStates'
            , pvdsVotesByTicket :: Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
pvdsVotesByTicket = Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
pvsVotesByTicket'
            , pvdsLastTicketNo :: PerasVoteTicketNo
pvdsLastTicketNo = PerasVoteTicketNo
pvdsLastTicketNo
            }