Skip to content

Commit 750e881

Browse files
amesgenagustinmista
amesgen
authored and
agustinmista
committed
Super basic scaffolding
1 parent de3deab commit 750e881

File tree

14 files changed

+179
-57
lines changed

14 files changed

+179
-57
lines changed

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs

Lines changed: 79 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44
{-# LANGUAGE FlexibleContexts #-}
55
{-# LANGUAGE FlexibleInstances #-}
66
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+
{-# LANGUAGE MultiParamTypeClasses #-}
78
{-# LANGUAGE ScopedTypeVariables #-}
89
{-# LANGUAGE TypeFamilies #-}
910
{-# LANGUAGE UndecidableInstances #-}
@@ -14,6 +15,10 @@ module Ouroboros.Consensus.Block.SupportsPeras
1415
, boostPerCert
1516
, BlockSupportsPeras (..)
1617
, PerasCert (..)
18+
, ValidatedPerasCert (..)
19+
, makePerasCfg
20+
, HasPerasCert (..)
21+
, HasPerasCertBoost (..)
1722
) where
1823

1924
import Data.Monoid (Sum (..))
@@ -45,24 +50,93 @@ instance Condense PerasWeight where
4550
boostPerCert :: PerasWeight
4651
boostPerCert = PerasWeight 15
4752

53+
-- TODO using 'Validated' for extra safety? Or some @.Unsafe@ module?
54+
data ValidatedPerasCert blk = ValidatedPerasCert
55+
{ vpcCert :: !(PerasCert blk)
56+
, vpcCertBoost :: !PerasWeight
57+
}
58+
deriving stock (Show, Eq, Ord, Generic)
59+
deriving anyclass NoThunks
60+
4861
class
49-
NoThunks (PerasCert blk) =>
62+
( Show (PerasCfg blk)
63+
, NoThunks (PerasCert blk)
64+
) =>
5065
BlockSupportsPeras blk
5166
where
67+
data PerasCfg blk
68+
5269
data PerasCert blk
5370

54-
perasCertRound :: PerasCert blk -> PerasRoundNo
71+
data PerasValidationErr blk
5572

56-
perasCertBoostedBlock :: PerasCert blk -> Point blk
73+
validatePerasCert ::
74+
PerasCfg blk ->
75+
-- | Current round number
76+
PerasRoundNo ->
77+
PerasCert blk ->
78+
Either (PerasValidationErr blk) (ValidatedPerasCert blk)
5779

5880
-- TODO degenerate instance for all blks to get things to compile
5981
instance StandardHash blk => BlockSupportsPeras blk where
82+
newtype PerasCfg blk = PerasCfg
83+
{ -- TODO eventually, this will come from the protocol parameters from the
84+
-- ledger state
85+
perasCfgWeightBoost :: PerasWeight
86+
}
87+
deriving stock (Show, Eq)
88+
6089
data PerasCert blk = PerasCert
6190
{ pcCertRound :: PerasRoundNo
6291
, pcCertBoostedBlock :: Point blk
6392
}
6493
deriving stock (Generic, Eq, Ord, Show)
6594
deriving anyclass NoThunks
6695

67-
perasCertRound = pcCertRound
68-
perasCertBoostedBlock = pcCertBoostedBlock
96+
data PerasValidationErr blk
97+
= PerasInFuture
98+
-- current round
99+
PerasRoundNo
100+
-- round of cert
101+
PerasRoundNo
102+
deriving stock (Show, Eq)
103+
104+
validatePerasCert cfg curRound cert
105+
| pcCertRound cert > curRound =
106+
Left $ PerasInFuture curRound (pcCertRound cert)
107+
| otherwise =
108+
Right
109+
ValidatedPerasCert
110+
{ vpcCert = cert
111+
, vpcCertBoost = perasCfgWeightBoost cfg
112+
}
113+
114+
-- | Derive a 'PerasCfg' from a 'BlockConfig'
115+
-- TODO this currently doesn't depend on 'BlockConfig' at all, but likely will
116+
makePerasCfg :: Maybe (BlockConfig blk) -> PerasCfg blk
117+
makePerasCfg _ =
118+
PerasCfg
119+
{ perasCfgWeightBoost = boostPerCert
120+
}
121+
122+
-- | Convenience classes to extract fields from both validated and unvalidated certificates
123+
class StandardHash blk => HasPerasCert cert blk where
124+
getPerasCert :: cert blk -> PerasCert blk
125+
126+
getPerasCertRound :: cert blk -> PerasRoundNo
127+
getPerasCertRound = pcCertRound . getPerasCert
128+
129+
getPerasCertBoostedBlock :: cert blk -> Point blk
130+
getPerasCertBoostedBlock = pcCertBoostedBlock . getPerasCert
131+
132+
instance StandardHash blk => HasPerasCert PerasCert blk where
133+
getPerasCert = id
134+
135+
instance StandardHash blk => HasPerasCert ValidatedPerasCert blk where
136+
getPerasCert = vpcCert
137+
138+
class HasPerasCertBoost cert blk where
139+
getPerasCertBoost :: cert blk -> PerasWeight
140+
141+
instance HasPerasCertBoost ValidatedPerasCert blk where
142+
getPerasCertBoost = vpcCertBoost

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs

Lines changed: 35 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,6 @@
1+
{-# LANGUAGE GADTs #-}
2+
{-# LANGUAGE StandaloneDeriving #-}
3+
14
-- | Instantiate 'ObjectPoolReader' and 'ObjectPoolWriter' using Peras
25
-- certificates from the 'PerasCertDB' (or the 'ChainDB' which is wrapping the
36
-- 'PerasCertDB').
@@ -8,6 +11,7 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert
811
, makePerasCertPoolWriterFromChainDB
912
) where
1013

14+
import GHC.Exception (throw)
1115
import Ouroboros.Consensus.Block
1216
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API
1317
import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
@@ -26,13 +30,13 @@ makePerasCertPoolReaderFromSnapshot ::
2630
ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m
2731
makePerasCertPoolReaderFromSnapshot getCertSnapshot =
2832
ObjectPoolReader
29-
{ oprObjectId = perasCertRound
33+
{ oprObjectId = getPerasCertRound
3034
, oprZeroTicketNo = PerasCertDB.zeroPerasCertTicketNo
3135
, oprObjectsAfter = \lastKnown limit -> do
3236
certSnapshot <- getCertSnapshot
3337
pure $
3438
take (fromIntegral limit) $
35-
[ (ticketNo, perasCertRound cert, pure cert)
39+
[ (ticketNo, getPerasCertRound cert, pure (getPerasCert cert))
3640
| (cert, ticketNo) <- PerasCertDB.getCertsAfter certSnapshot lastKnown
3741
]
3842
}
@@ -48,9 +52,10 @@ makePerasCertPoolWriterFromCertDB ::
4852
PerasCertDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m
4953
makePerasCertPoolWriterFromCertDB perasCertDB =
5054
ObjectPoolWriter
51-
{ opwObjectId = perasCertRound
52-
, opwAddObjects =
53-
mapM_ $ PerasCertDB.addCert perasCertDB
55+
{ opwObjectId = getPerasCertRound
56+
, opwAddObjects = \certs -> do
57+
let validatedCerts = validatePerasCerts certs
58+
mapM_ (PerasCertDB.addCert perasCertDB) validatedCerts
5459
, opwHasObject = do
5560
certSnapshot <- atomically $ PerasCertDB.getCertSnapshot perasCertDB
5661
pure $ PerasCertDB.containsCert certSnapshot
@@ -67,10 +72,32 @@ makePerasCertPoolWriterFromChainDB ::
6772
ChainDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m
6873
makePerasCertPoolWriterFromChainDB chainDB =
6974
ObjectPoolWriter
70-
{ opwObjectId = perasCertRound
71-
, opwAddObjects =
72-
mapM_ $ ChainDB.addPerasCertAsync chainDB
75+
{ opwObjectId = getPerasCertRound
76+
, opwAddObjects = \certs -> do
77+
let validatedCerts = validatePerasCerts certs
78+
mapM_ (ChainDB.addPerasCertAsync chainDB) validatedCerts
7379
, opwHasObject = do
7480
certSnapshot <- atomically $ ChainDB.getPerasCertSnapshot chainDB
7581
pure $ PerasCertDB.containsCert certSnapshot
7682
}
83+
84+
-- TODO following the same approach as 'ChainSyncClientException', but why not using GADT syntax?
85+
data PerasCertInboundException
86+
= forall blk. PerasCertValidationError (PerasValidationErr blk)
87+
88+
deriving instance Show PerasCertInboundException
89+
90+
instance Exception PerasCertInboundException
91+
92+
validatePerasCerts ::
93+
StandardHash blk =>
94+
[PerasCert blk] ->
95+
[ValidatedPerasCert blk]
96+
validatePerasCerts certs = do
97+
let perasCfg = makePerasCfg Nothing
98+
perasRoundNo = PerasRoundNo 999
99+
-- TODO replace these mocked-up values with real
100+
-- ones when all the required plumbing is in place
101+
case sequence (validatePerasCert perasCfg perasRoundNo <$> certs) of
102+
Left validationErr -> throw (PerasCertValidationError validationErr)
103+
Right validatedCerts -> validatedCerts

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -392,8 +392,8 @@ data ChainDB m blk = ChainDB
392392
, getStatistics :: m (Maybe Statistics)
393393
-- ^ Get statistics from the LedgerDB, in particular the number of entries
394394
-- in the tables.
395-
, addPerasCertAsync :: PerasCert blk -> m (AddPerasCertPromise m)
396-
-- ^ TODO
395+
, addPerasCertAsync :: ValidatedPerasCert blk -> m (AddPerasCertPromise m)
396+
-- ^ TODO docs
397397
, getPerasWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk))
398398
-- ^ TODO
399399
, getPerasCertSnapshot :: STM m (PerasCertSnapshot blk)
@@ -530,7 +530,7 @@ newtype AddPerasCertPromise m = AddPerasCertPromise
530530
-- impossible).
531531
}
532532

533-
addPerasCertSync :: IOLike m => ChainDB m blk -> PerasCert blk -> m ()
533+
addPerasCertSync :: IOLike m => ChainDB m blk -> ValidatedPerasCert blk -> m ()
534534
addPerasCertSync chainDB cert =
535535
waitPerasCertProcessed =<< addPerasCertAsync chainDB cert
536536

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -647,7 +647,7 @@ addBlockRunner fuse cdb@CDB{..} = forever $ do
647647
ChainSelAddPerasCert cert _varProcessed ->
648648
traceWith cdbTracer $
649649
TraceAddPerasCertEvent $
650-
PoppedPerasCertFromQueue (perasCertRound cert) (perasCertBoostedBlock cert)
650+
PoppedPerasCertFromQueue (getPerasCertRound cert) (getPerasCertBoostedBlock cert)
651651
chainSelSync cdb message
652652
lift $ atomically $ processedChainSelMessage cdbChainSelQueue message
653653
)

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

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -331,7 +331,7 @@ addPerasCertAsync ::
331331
forall m blk.
332332
(IOLike m, HasHeader blk) =>
333333
ChainDbEnv m blk ->
334-
PerasCert blk ->
334+
ValidatedPerasCert blk ->
335335
m (AddPerasCertPromise m)
336336
addPerasCertAsync CDB{cdbTracer, cdbChainSelQueue} =
337337
addPerasCertToQueue (TraceAddPerasCertEvent >$< cdbTracer) cdbChainSelQueue
@@ -529,10 +529,10 @@ chainSelSync cdb@CDB{..} (ChainSelAddPerasCert cert varProcessed) = do
529529
tracer = TraceAddPerasCertEvent >$< cdbTracer
530530

531531
certRound :: PerasRoundNo
532-
certRound = perasCertRound cert
532+
certRound = getPerasCertRound cert
533533

534534
boostedBlock :: Point blk
535-
boostedBlock = perasCertBoostedBlock cert
535+
boostedBlock = getPerasCertBoostedBlock cert
536536

537537
-- | Return 'True' when the given header should be ignored when adding it
538538
-- because it is too old, i.e., we wouldn't be able to switch to a chain

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

Lines changed: 3 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -553,7 +553,7 @@ data ChainSelMessage m blk
553553
ChainSelAddBlock !(BlockToAdd m blk)
554554
| -- | Add a Peras certificate
555555
ChainSelAddPerasCert
556-
!(PerasCert blk)
556+
!(ValidatedPerasCert blk)
557557
-- | Used for 'AddPerasCertPromise'.
558558
!(StrictTMVar m ())
559559
| -- | Reprocess blocks that have been postponed by the LoE.
@@ -609,7 +609,7 @@ addPerasCertToQueue ::
609609
(IOLike m, StandardHash blk) =>
610610
Tracer m (TraceAddPerasCertEvent blk) ->
611611
ChainSelQueue m blk ->
612-
PerasCert blk ->
612+
ValidatedPerasCert blk ->
613613
m (AddPerasCertPromise m)
614614
addPerasCertToQueue tracer ChainSelQueue{varChainSelQueue} cert = do
615615
varProcessed <- newEmptyTMVarIO
@@ -623,8 +623,7 @@ addPerasCertToQueue tracer ChainSelQueue{varChainSelQueue} cert = do
623623
{ waitPerasCertProcessed = atomically $ takeTMVar varProcessed
624624
}
625625
where
626-
addedToQueue =
627-
AddedPerasCertToQueue (perasCertRound cert) (perasCertBoostedBlock cert)
626+
addedToQueue = AddedPerasCertToQueue (getPerasCertRound cert) (getPerasCertBoostedBlock cert)
628627

629628
-- | Try to add blocks again that were postponed due to the LoE.
630629
addReprocessLoEBlocks ::

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -21,7 +21,8 @@ import Ouroboros.Consensus.Util.IOLike
2121
import Ouroboros.Consensus.Util.STM (WithFingerprint (..))
2222

2323
data PerasCertDB m blk = PerasCertDB
24-
{ addCert :: PerasCert blk -> m AddPerasCertResult
24+
{ addCert :: ValidatedPerasCert blk -> m AddPerasCertResult
25+
-- ^ TODO docs
2526
, getWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk))
2627
-- ^ Return the Peras weights in order compare the current selection against
2728
-- potential candidate chains, namely the weights for blocks not older than
@@ -44,7 +45,7 @@ data AddPerasCertResult = AddedPerasCertToDB | PerasCertAlreadyInDB
4445
data PerasCertSnapshot blk = PerasCertSnapshot
4546
{ containsCert :: PerasRoundNo -> Bool
4647
-- ^ Do we have the certificate for this round?
47-
, getCertsAfter :: PerasCertTicketNo -> [(PerasCert blk, PerasCertTicketNo)]
48+
, getCertsAfter :: PerasCertTicketNo -> [(ValidatedPerasCert blk, PerasCertTicketNo)]
4849
}
4950

5051
-- TODO: Once we store historical certificates on disk, this should (also) track

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -144,7 +144,7 @@ implAddCert ::
144144
, StandardHash blk
145145
) =>
146146
PerasCertDbEnv m blk ->
147-
PerasCert blk ->
147+
ValidatedPerasCert blk ->
148148
m AddPerasCertResult
149149
implAddCert env cert = do
150150
traceWith pcdbTracer $ AddingPerasCert roundNo boostedPt
@@ -186,8 +186,8 @@ implAddCert env cert = do
186186
, pcdbVolatileState
187187
} = env
188188

189-
roundNo = perasCertRound cert
190-
boostedPt = perasCertBoostedBlock cert
189+
boostedPt = getPerasCertBoostedBlock cert
190+
roundNo = getPerasCertRound cert
191191

192192
implGetWeightSnapshot ::
193193
IOLike m =>
@@ -237,7 +237,7 @@ implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot =
237237
}
238238
where
239239
keepCert cert =
240-
pointSlot (perasCertBoostedBlock cert) >= NotOrigin slot
240+
pointSlot (getPerasCertBoostedBlock cert) >= NotOrigin slot
241241

242242
{-------------------------------------------------------------------------------
243243
Implementation-internal types
@@ -246,13 +246,13 @@ implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot =
246246
-- | Volatile Peras certificate state, i.e. certificates that could influence
247247
-- chain selection by boosting a volatile block.
248248
data PerasVolatileCertState blk = PerasVolatileCertState
249-
{ pvcsCerts :: !(Map PerasRoundNo (PerasCert blk))
249+
{ pvcsCerts :: !(Map PerasRoundNo (ValidatedPerasCert blk))
250250
-- ^ The boosted blocks by 'RoundNo' of all certificates currently in the db.
251251
, pvcsWeightByPoint :: !(PerasWeightSnapshot blk)
252252
-- ^ The weight of boosted blocks w.r.t. the certificates currently in the db.
253253
--
254254
-- INVARIANT: In sync with 'pvcsCerts'.
255-
, pvcsCertsByTicket :: !(Map PerasCertTicketNo (PerasCert blk))
255+
, pvcsCertsByTicket :: !(Map PerasCertTicketNo (ValidatedPerasCert blk))
256256
-- ^ The certificates by 'PerasCertTicketNo'.
257257
--
258258
-- INVARIANT: In sync with 'pvcsCerts'.

‎ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -125,6 +125,8 @@ deriving anyclass instance ToExpr PerasWeight
125125

126126
deriving anyclass instance ToExpr (HeaderHash blk) => ToExpr (PerasCert blk)
127127

128+
deriving anyclass instance ToExpr (HeaderHash blk) => ToExpr (ValidatedPerasCert blk)
129+
128130
{-------------------------------------------------------------------------------
129131
si-timers
130132
--------------------------------------------------------------------------------}

‎ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -78,7 +78,12 @@ newCertDB certs = do
7878
db <- PerasCertDB.openDB (PerasCertDB.PerasCertDbArgs @Identity nullTracer)
7979
mapM_
8080
( \cert -> do
81-
result <- PerasCertDB.addCert db cert
81+
let validatedCert =
82+
ValidatedPerasCert
83+
{ vpcCert = cert
84+
, vpcCertBoost = boostPerCert
85+
}
86+
result <- PerasCertDB.addCert db validatedCert
8287
case result of
8388
AddedPerasCertToDB -> pure ()
8489
PerasCertAlreadyInDB -> throwIO (userError "Expected AddedPerasCertToDB, but cert was already in DB")
@@ -121,6 +126,6 @@ prop_smoke protocolConstants (ListWithUniqueIds certs) =
121126
getAllInboundPoolContent = do
122127
snap <- atomically $ PerasCertDB.getCertSnapshot inboundPool
123128
let rawContent = PerasCertDB.getCertsAfter snap (PerasCertDB.zeroPerasCertTicketNo)
124-
pure $ fst <$> rawContent
129+
pure $ getPerasCert . fst <$> rawContent
125130

126131
return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent)

0 commit comments

Comments
 (0)