{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE StandaloneDeriving #-}

module Test.Ouroboros.Storage.PerasCertDB.Model
  ( Model (..)
  , initModel
  , openDB
  , addCert
  , getWeightSnapshot
  , getLatestCertSeen
  , garbageCollect
  , hasRoundNo
  ) where

import Data.Set (Set)
import qualified Data.Set as Set
import Data.TreeDiff (ToExpr (..), defaultExprViaShow)
import GHC.Generics (Generic)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..))
import Ouroboros.Consensus.Peras.Weight
  ( PerasWeightSnapshot
  , mkPerasWeightSnapshot
  )
import Ouroboros.Consensus.Storage.PerasCertDB.API
  ( AddPerasCertResult (..)
  , WithBoostedBlockStatus (..)
  , forgetBoostedBlockStatus
  )

data Model blk = Model
  { forall blk.
Model blk -> Set (WithArrivalTime (ValidatedPerasCert blk))
certs :: Set (WithArrivalTime (ValidatedPerasCert blk))
  , forall blk.
Model blk
-> Maybe
     (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
latestCertSeen :: Maybe (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
  , forall blk. Model blk -> Bool
open :: Bool
  }
  deriving (forall x. Model blk -> Rep (Model blk) x)
-> (forall x. Rep (Model blk) x -> Model blk)
-> Generic (Model blk)
forall x. Rep (Model blk) x -> Model blk
forall x. Model blk -> Rep (Model blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (Model blk) x -> Model blk
forall blk x. Model blk -> Rep (Model blk) x
$cfrom :: forall blk x. Model blk -> Rep (Model blk) x
from :: forall x. Model blk -> Rep (Model blk) x
$cto :: forall blk x. Rep (Model blk) x -> Model blk
to :: forall x. Rep (Model blk) x -> Model blk
Generic

deriving instance StandardHash blk => Show (Model blk)

instance StandardHash blk => ToExpr (Model blk) where
  toExpr :: Model blk -> Expr
toExpr = Model blk -> Expr
forall a. Show a => a -> Expr
defaultExprViaShow

initModel :: Model blk
initModel :: forall blk. Model blk
initModel = Model{open :: Bool
open = Bool
False, certs :: Set (WithArrivalTime (ValidatedPerasCert blk))
certs = Set (WithArrivalTime (ValidatedPerasCert blk))
forall a. Set a
Set.empty, latestCertSeen :: Maybe
  (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
latestCertSeen = Maybe
  (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
forall a. Maybe a
Nothing}

openDB :: Model blk -> Model blk
openDB :: forall blk. Model blk -> Model blk
openDB Model blk
model = Model blk
model{open = True}

addCert ::
  StandardHash blk =>
  Model blk -> WithArrivalTime (ValidatedPerasCert blk) -> (AddPerasCertResult, Model blk)
addCert :: forall blk.
StandardHash blk =>
Model blk
-> WithArrivalTime (ValidatedPerasCert blk)
-> (AddPerasCertResult, Model blk)
addCert model :: Model blk
model@Model{Set (WithArrivalTime (ValidatedPerasCert blk))
certs :: forall blk.
Model blk -> Set (WithArrivalTime (ValidatedPerasCert blk))
certs :: Set (WithArrivalTime (ValidatedPerasCert blk))
certs, Maybe
  (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
latestCertSeen :: forall blk.
Model blk
-> Maybe
     (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
latestCertSeen :: Maybe
  (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
latestCertSeen} WithArrivalTime (ValidatedPerasCert blk)
cert
  | Set (WithArrivalTime (ValidatedPerasCert blk))
certs Set (WithArrivalTime (ValidatedPerasCert blk))
-> WithArrivalTime (ValidatedPerasCert blk) -> Bool
forall blk.
Set (WithArrivalTime (ValidatedPerasCert blk))
-> WithArrivalTime (ValidatedPerasCert blk) -> Bool
`hasRoundNo` WithArrivalTime (ValidatedPerasCert blk)
cert = (AddPerasCertResult
PerasCertAlreadyInDB, Model blk
model)
  | Bool
otherwise = (AddPerasCertResult
AddedPerasCertToDB, Model blk
model{certs = certs', latestCertSeen = latestCertSeen'})
 where
  certs' :: Set (WithArrivalTime (ValidatedPerasCert blk))
certs' = WithArrivalTime (ValidatedPerasCert blk)
-> Set (WithArrivalTime (ValidatedPerasCert blk))
-> Set (WithArrivalTime (ValidatedPerasCert blk))
forall a. Ord a => a -> Set a -> Set a
Set.insert WithArrivalTime (ValidatedPerasCert blk)
cert Set (WithArrivalTime (ValidatedPerasCert blk))
certs
  latestCertSeen' :: Maybe
  (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
latestCertSeen' =
    case Maybe
  (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
latestCertSeen of
      Maybe
  (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
Nothing ->
        WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk))
-> Maybe
     (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
forall a. a -> Maybe a
Just (WithArrivalTime (ValidatedPerasCert blk)
-> WithBoostedBlockStatus
     (WithArrivalTime (ValidatedPerasCert blk))
forall cert. cert -> WithBoostedBlockStatus cert
CertBoostingBlockInVolatileDB WithArrivalTime (ValidatedPerasCert blk)
cert)
      Just WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk))
prev
        | WithArrivalTime (ValidatedPerasCert blk) -> PerasRoundNo
forall cert blk. IsPerasCert cert blk => cert -> PerasRoundNo
getPerasCertRound WithArrivalTime (ValidatedPerasCert blk)
cert
            PerasRoundNo -> PerasRoundNo -> Bool
forall a. Ord a => a -> a -> Bool
> WithArrivalTime (ValidatedPerasCert blk) -> PerasRoundNo
forall cert blk. IsPerasCert cert blk => cert -> PerasRoundNo
getPerasCertRound (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk))
-> WithArrivalTime (ValidatedPerasCert blk)
forall cert. WithBoostedBlockStatus cert -> cert
forgetBoostedBlockStatus WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk))
prev) ->
            WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk))
-> Maybe
     (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
forall a. a -> Maybe a
Just (WithArrivalTime (ValidatedPerasCert blk)
-> WithBoostedBlockStatus
     (WithArrivalTime (ValidatedPerasCert blk))
forall cert. cert -> WithBoostedBlockStatus cert
CertBoostingBlockInVolatileDB WithArrivalTime (ValidatedPerasCert blk)
cert)
        | Bool
otherwise ->
            WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk))
-> Maybe
     (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
forall a. a -> Maybe a
Just WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk))
prev

hasRoundNo ::
  Set (WithArrivalTime (ValidatedPerasCert blk)) ->
  WithArrivalTime (ValidatedPerasCert blk) ->
  Bool
hasRoundNo :: forall blk.
Set (WithArrivalTime (ValidatedPerasCert blk))
-> WithArrivalTime (ValidatedPerasCert blk) -> Bool
hasRoundNo Set (WithArrivalTime (ValidatedPerasCert blk))
certs WithArrivalTime (ValidatedPerasCert blk)
cert =
  (WithArrivalTime (ValidatedPerasCert blk) -> PerasRoundNo
forall cert blk. IsPerasCert cert blk => cert -> PerasRoundNo
getPerasCertRound WithArrivalTime (ValidatedPerasCert blk)
cert) PerasRoundNo -> Set PerasRoundNo -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` ((WithArrivalTime (ValidatedPerasCert blk) -> PerasRoundNo)
-> Set (WithArrivalTime (ValidatedPerasCert blk))
-> Set PerasRoundNo
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map WithArrivalTime (ValidatedPerasCert blk) -> PerasRoundNo
forall cert blk. IsPerasCert cert blk => cert -> PerasRoundNo
getPerasCertRound Set (WithArrivalTime (ValidatedPerasCert blk))
certs)

getWeightSnapshot ::
  StandardHash blk =>
  Model blk -> PerasWeightSnapshot blk
getWeightSnapshot :: forall blk.
StandardHash blk =>
Model blk -> PerasWeightSnapshot blk
getWeightSnapshot Model{Set (WithArrivalTime (ValidatedPerasCert blk))
certs :: forall blk.
Model blk -> Set (WithArrivalTime (ValidatedPerasCert blk))
certs :: Set (WithArrivalTime (ValidatedPerasCert blk))
certs} =
  [(Point blk, PerasWeight)] -> PerasWeightSnapshot blk
forall blk.
StandardHash blk =>
[(Point blk, PerasWeight)] -> PerasWeightSnapshot blk
mkPerasWeightSnapshot
    [ (WithArrivalTime (ValidatedPerasCert blk) -> Point blk
forall cert blk. IsPerasCert cert blk => cert -> Point blk
getPerasCertPoint WithArrivalTime (ValidatedPerasCert blk)
cert, ValidatedPerasCert blk -> PerasWeight
forall blk. ValidatedPerasCert blk -> PerasWeight
vpcCertBoost (WithArrivalTime (ValidatedPerasCert blk) -> ValidatedPerasCert blk
forall a. WithArrivalTime a -> a
forgetArrivalTime WithArrivalTime (ValidatedPerasCert blk)
cert))
    | WithArrivalTime (ValidatedPerasCert blk)
cert <- Set (WithArrivalTime (ValidatedPerasCert blk))
-> [WithArrivalTime (ValidatedPerasCert blk)]
forall a. Set a -> [a]
Set.toList Set (WithArrivalTime (ValidatedPerasCert blk))
certs
    ]

getLatestCertSeen ::
  Model blk ->
  Maybe (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
getLatestCertSeen :: forall blk.
Model blk
-> Maybe
     (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
getLatestCertSeen Model{Maybe
  (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
latestCertSeen :: forall blk.
Model blk
-> Maybe
     (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
latestCertSeen :: Maybe
  (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
latestCertSeen} =
  Maybe
  (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
latestCertSeen

garbageCollect :: SlotNo -> Model blk -> Model blk
garbageCollect :: forall blk. SlotNo -> Model blk -> Model blk
garbageCollect SlotNo
slotNo model :: Model blk
model@Model{Set (WithArrivalTime (ValidatedPerasCert blk))
certs :: forall blk.
Model blk -> Set (WithArrivalTime (ValidatedPerasCert blk))
certs :: Set (WithArrivalTime (ValidatedPerasCert blk))
certs, Maybe
  (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
latestCertSeen :: forall blk.
Model blk
-> Maybe
     (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
latestCertSeen :: Maybe
  (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))
latestCertSeen} =
  Model blk
model
    { certs = Set.filter keepCert certs
    , latestCertSeen = updateIfBoostingGarbageCollectedBlock <$> latestCertSeen
    }
 where
  keepCert :: cert -> Bool
keepCert cert
cert = Point block -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot (cert -> Point block
forall cert blk. IsPerasCert cert blk => cert -> Point blk
getPerasCertPoint cert
cert) WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
slotNo

  updateIfBoostingGarbageCollectedBlock :: WithBoostedBlockStatus cert -> WithBoostedBlockStatus cert
updateIfBoostingGarbageCollectedBlock WithBoostedBlockStatus cert
cert
    | Point block -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot (cert -> Point block
forall cert blk. IsPerasCert cert blk => cert -> Point blk
getPerasCertPoint (WithBoostedBlockStatus cert -> cert
forall cert. WithBoostedBlockStatus cert -> cert
forgetBoostedBlockStatus WithBoostedBlockStatus cert
cert))
        WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
slotNo =
        cert -> WithBoostedBlockStatus cert
forall cert. cert -> WithBoostedBlockStatus cert
CertBoostingBlockNoLongerInVolatileDB (WithBoostedBlockStatus cert -> cert
forall cert. WithBoostedBlockStatus cert -> cert
forgetBoostedBlockStatus WithBoostedBlockStatus cert
cert)
    | Bool
otherwise =
        WithBoostedBlockStatus cert
cert