From dc5cbc8e554061c3c0de8c3e89c005411b8da975 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Mon, 4 Nov 2019 12:04:06 +0100 Subject: [PATCH 1/2] Rename ByronBlockOrEBB to ByronBlock --- .../src/Ouroboros/Consensus/Ledger/Byron.hs | 228 +++++++++--------- .../Ouroboros/Consensus/Ledger/Byron/Forge.hs | 36 +-- .../Consensus/Node/ProtocolInfo/Byron.hs | 2 +- .../src/Ouroboros/Consensus/Node/Run/Byron.hs | 6 +- .../src/Ouroboros/Consensus/Protocol.hs | 2 +- .../Test/Consensus/Ledger/Byron.hs | 38 ++- .../test-consensus/Test/Dynamic/RealPBFT.hs | 6 +- .../test-consensus/Test/Dynamic/TxGen.hs | 4 +- .../Test/Ouroboros/Storage/ChainDB/ImmDB.hs | 16 +- ouroboros-consensus/tools/db-analyse/Main.hs | 22 +- ouroboros-consensus/tools/db-convert/Main.hs | 9 +- 11 files changed, 180 insertions(+), 189 deletions(-) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs index 4469b6022de..718e75c3874 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs @@ -29,7 +29,7 @@ module Ouroboros.Consensus.Ledger.Byron , ByronApplyTxError (..) , mkByronGenTx -- * Block Fetch integration - , byronBlockOrEBBMatchesHeader + , byronBlockMatchesHeader -- * Ledger , LedgerState (..) , LedgerConfig (..) @@ -56,11 +56,11 @@ module Ouroboros.Consensus.Ledger.Byron -- Test.Consensus.Ledger.Byron -- * EBBs - , ByronBlockOrEBB (..) + , ByronBlock(..) , pattern ByronHeaderRegular , pattern ByronHeaderBoundary - , mkByronHeaderOrEBB - , mkByronBlockOrEBB + , mkByronHeader + , mkByronBlock , annotateBoundary , fromCBORAHeaderOrBoundary ) where @@ -174,13 +174,13 @@ convertSlot = coerce Epoch Boundary Blocks -------------------------------------------------------------------------------} -data ByronBlockOrEBB = ByronBlockOrEBB +data ByronBlock = ByronBlock { bbRaw :: !(CC.Block.ABlockOrBoundary ByteString) , bbSlotNo :: !SlotNo , bbHash :: !ByronHash } deriving (Eq, Show) --- | Internal: construct @Header ByronBlockOrEBB@ with known hash +-- | Internal: construct @Header ByronBlock@ with known hash -- -- This is useful when we are constructing a header from a @ByronBlock@, where -- we cache the cache. @@ -188,12 +188,12 @@ data ByronBlockOrEBB = ByronBlockOrEBB -- NOTE: The @slotNo@ should correspond to the one that we can compute from the -- header (using 'computeHeaderSlot') -- except we can't actually /do/ that -- conversion here since we'd need the know @epochSlots@ for that. -mkByronHeaderOrEBB' :: SlotNo - -> ByronHash - -> Either (CC.Block.ABoundaryHeader ByteString) - (CC.Block.AHeader ByteString) - -> Header ByronBlockOrEBB -mkByronHeaderOrEBB' slotNo hdrHash header = case header of +mkByronHeader' :: SlotNo + -> ByronHash + -> Either (CC.Block.ABoundaryHeader ByteString) + (CC.Block.AHeader ByteString) + -> Header ByronBlock +mkByronHeader' slotNo hdrHash header = case header of Left ebb -> ByronHeaderBoundary ebb slotNo hdrHash Right mb -> ByronHeaderRegular mb slotNo hdrHash @@ -203,12 +203,12 @@ mkByronHash :: Either (CC.Block.ABoundaryHeader ByteString) mkByronHash (Left ebb) = ByronHash $ CC.Block.boundaryHeaderHashAnnotated ebb mkByronHash (Right mb) = ByronHash $ CC.Block.headerHashAnnotated mb -mkByronHeaderOrEBB :: CC.Slot.EpochSlots - -> Either (CC.Block.ABoundaryHeader ByteString) - (CC.Block.AHeader ByteString) - -> Header ByronBlockOrEBB -mkByronHeaderOrEBB epochSlots header = - mkByronHeaderOrEBB' slotNo hdrHash header +mkByronHeader :: CC.Slot.EpochSlots + -> Either (CC.Block.ABoundaryHeader ByteString) + (CC.Block.AHeader ByteString) + -> Header ByronBlock +mkByronHeader epochSlots header = + mkByronHeader' slotNo hdrHash header where slotNo = computeHeaderSlot epochSlots header hdrHash = mkByronHash header @@ -222,32 +222,32 @@ computeHeaderSlot _ (Right hdr) = computeHeaderSlot epochSlots (Left hdr) = SlotNo $ CC.Slot.unEpochSlots epochSlots * CC.Block.boundaryEpoch hdr -instance GetHeader ByronBlockOrEBB where - data Header ByronBlockOrEBB = +instance GetHeader ByronBlock where + data Header ByronBlock = ByronHeaderRegular !(CC.Block.AHeader ByteString) !SlotNo !ByronHash | ByronHeaderBoundary !(CC.Block.ABoundaryHeader ByteString) !SlotNo !ByronHash deriving (Eq, Show, Generic) - getHeader (ByronBlockOrEBB (CC.Block.ABOBBlock b) slotNo hdrHash) = + getHeader (ByronBlock (CC.Block.ABOBBlock b) slotNo hdrHash) = ByronHeaderRegular (CC.Block.blockHeader b) slotNo hdrHash - getHeader (ByronBlockOrEBB (CC.Block.ABOBBoundary b) slotNo hdrHash) = + getHeader (ByronBlock (CC.Block.ABOBBoundary b) slotNo hdrHash) = ByronHeaderBoundary (CC.Block.boundaryHeader b) slotNo hdrHash -type instance HeaderHash ByronBlockOrEBB = ByronHash +type instance HeaderHash ByronBlock = ByronHash -instance NoUnexpectedThunks (Header ByronBlockOrEBB) where - showTypeOf _ = show $ typeRep (Proxy @(Header ByronBlockOrEBB)) +instance NoUnexpectedThunks (Header ByronBlock) where + showTypeOf _ = show $ typeRep (Proxy @(Header ByronBlock)) -instance SupportedBlock ByronBlockOrEBB +instance SupportedBlock ByronBlock -instance HasHeader ByronBlockOrEBB where +instance HasHeader ByronBlock where blockHash = blockHash . getHeader blockPrevHash = castHash . blockPrevHash . getHeader blockSlot = blockSlot . getHeader blockNo = blockNo . getHeader blockInvariant = const True -instance HasHeader (Header ByronBlockOrEBB) where +instance HasHeader (Header ByronBlock) where blockHash (ByronHeaderRegular _ _ h) = h blockHash (ByronHeaderBoundary _ _ h) = h @@ -274,13 +274,13 @@ instance HasHeader (Header ByronBlockOrEBB) where blockInvariant = const True -instance Measured BlockMeasure ByronBlockOrEBB where +instance Measured BlockMeasure ByronBlock where measure = blockMeasure -instance StandardHash ByronBlockOrEBB +instance StandardHash ByronBlock -instance HeaderSupportsPBft ByronConfig PBftCardanoCrypto (Header ByronBlockOrEBB) where - type OptSigned (Header ByronBlockOrEBB) = Annotated CC.Block.ToSign ByteString +instance HeaderSupportsPBft ByronConfig PBftCardanoCrypto (Header ByronBlock) where + type OptSigned (Header ByronBlock) = Annotated CC.Block.ToSign ByteString headerPBftFields _ (ByronHeaderBoundary{}) = Nothing headerPBftFields cfg (ByronHeaderRegular hdr _ _) = Just ( @@ -304,20 +304,20 @@ instance HeaderSupportsPBft ByronConfig PBftCardanoCrypto (Header ByronBlockOrEB where epochSlots = pbftEpochSlots $ pbftExtConfig cfg -type instance BlockProtocol ByronBlockOrEBB = ByronConsensusProtocol +type instance BlockProtocol ByronBlock = ByronConsensusProtocol -instance UpdateLedger ByronBlockOrEBB where +instance UpdateLedger ByronBlock where - data LedgerState ByronBlockOrEBB = ByronLedgerState + data LedgerState ByronBlock = ByronLedgerState { blsCurrent :: !CC.Block.ChainValidationState -- | Slot-bounded snapshots of the chain state , blsSnapshots :: !(Seq.StrictSeq (SlotBounded (PBftLedgerView PBftCardanoCrypto))) } deriving (Eq, Show, Generic) - type LedgerError ByronBlockOrEBB = CC.Block.ChainValidationError + type LedgerError ByronBlock = CC.Block.ChainValidationError - newtype LedgerConfig ByronBlockOrEBB = ByronLedgerConfig { + newtype LedgerConfig ByronBlock = ByronLedgerConfig { unByronLedgerConfig :: CC.Genesis.Config } @@ -347,19 +347,19 @@ instance UpdateLedger ByronBlockOrEBB where fixPMI pmi = reAnnotate $ Annotated pmi () - applyLedgerBlock = applyByronLedgerBlockOrEBB + applyLedgerBlock = applyByronLedgerBlock (fromBlockValidationMode CC.Block.BlockValidation) reapplyLedgerBlock cfg blk st = let validationMode = fromBlockValidationMode CC.Block.NoBlockValidation -- Given a 'BlockValidationMode' of 'NoBlockValidation', a call to - -- 'applyByronLedgerBlockOrEBB' shouldn't fail since the ledger layer + -- 'applyByronLedgerBlock' shouldn't fail since the ledger layer -- won't be performing any block validation checks. - -- However, because 'applyByronLedgerBlockOrEBB' can fail in the event it + -- However, because 'applyByronLedgerBlock' can fail in the event it -- is given a 'BlockValidationMode' of 'BlockValidation', it still /looks/ -- like it can fail (since its type doesn't change based on the -- 'ValidationMode') and we must still treat it as such. - in case runExcept (applyByronLedgerBlockOrEBB validationMode cfg blk st) of + in case runExcept (applyByronLedgerBlock validationMode cfg blk st) of Left err -> error ("reapplyLedgerBlock: unexpected error: " <> show err) Right st' -> st' @@ -371,19 +371,19 @@ instance UpdateLedger ByronBlockOrEBB where where slot = convertSlot (CC.Block.cvsLastSlot state) -instance NoUnexpectedThunks (LedgerState ByronBlockOrEBB) +instance NoUnexpectedThunks (LedgerState ByronBlock) -- use generic instance -instance ConfigContainsGenesis (LedgerConfig ByronBlockOrEBB) where +instance ConfigContainsGenesis (LedgerConfig ByronBlock) where genesisConfig = unByronLedgerConfig applyABlock :: ValidationMode -> CC.Genesis.Config -> CC.Block.ABlock ByteString -> CC.Block.HeaderHash - -> LedgerState (ByronBlockOrEBB) - -> Except (LedgerError (ByronBlockOrEBB)) - (LedgerState (ByronBlockOrEBB)) + -> LedgerState (ByronBlock) + -> Except (LedgerError ByronBlock) + (LedgerState ByronBlock) applyABlock validationMode cfg block @@ -447,16 +447,16 @@ applyABlock validationMode trimSnapshots = Seq.dropWhileL $ \ss -> sbUpper ss < convertSlot (CC.Block.blockSlot block) - 2 * coerce k -applyByronLedgerBlockOrEBB :: ValidationMode - -> LedgerConfig ByronBlockOrEBB - -> ByronBlockOrEBB - -> LedgerState ByronBlockOrEBB - -> Except (LedgerError ByronBlockOrEBB) - (LedgerState ByronBlockOrEBB) -applyByronLedgerBlockOrEBB validationMode - (ByronLedgerConfig cfg) - (ByronBlockOrEBB blk _ (ByronHash blkHash)) - bs@(ByronLedgerState state snapshots) = +applyByronLedgerBlock :: ValidationMode + -> LedgerConfig ByronBlock + -> ByronBlock + -> LedgerState ByronBlock + -> Except (LedgerError ByronBlock) + (LedgerState ByronBlock) +applyByronLedgerBlock validationMode + (ByronLedgerConfig cfg) + (ByronBlock blk _ (ByronHash blkHash)) + bs@(ByronLedgerState state snapshots) = case blk of CC.Block.ABOBBlock b -> applyABlock validationMode cfg b blkHash bs @@ -472,10 +472,10 @@ applyByronLedgerBlockOrEBB validationMode hdr = CC.Block.boundaryHeader b CC.Slot.EpochSlots epochSlots = CC.Genesis.configEpochSlots cfg -mkByronBlockOrEBB :: CC.Slot.EpochSlots - -> CC.Block.ABlockOrBoundary ByteString - -> ByronBlockOrEBB -mkByronBlockOrEBB epochSlots blk = ByronBlockOrEBB { +mkByronBlock :: CC.Slot.EpochSlots + -> CC.Block.ABlockOrBoundary ByteString + -> ByronBlock +mkByronBlock epochSlots blk = ByronBlock { bbRaw = blk , bbSlotNo = computeHeaderSlot epochSlots hdr , bbHash = mkByronHash hdr @@ -494,9 +494,9 @@ mkBlockOrBoundaryHeader blk = case blk of -- -- This should be used only when forging blocks (not when receiving blocks -- over the wire). -annotateByronBlock :: CC.Slot.EpochSlots -> CC.Block.Block -> ByronBlockOrEBB +annotateByronBlock :: CC.Slot.EpochSlots -> CC.Block.Block -> ByronBlock annotateByronBlock epochSlots = - mkByronBlockOrEBB epochSlots + mkByronBlock epochSlots . CC.Block.ABOBBlock . annotateBlock epochSlots @@ -504,12 +504,12 @@ annotateByronBlock epochSlots = Condense instances -------------------------------------------------------------------------------} -instance Condense ByronBlockOrEBB where - condense (ByronBlockOrEBB (CC.Block.ABOBBlock blk) _slotNo (ByronHash hdrHash)) = +instance Condense ByronBlock where + condense (ByronBlock (CC.Block.ABOBBlock blk) _slotNo (ByronHash hdrHash)) = "(header: " <> condenseAHeader (CC.Block.blockHeader blk) hdrHash <> ", body: " <> condenseABlock blk <> ")" - condense (ByronBlockOrEBB (CC.Block.ABOBBoundary ebb) _ _) = + condense (ByronBlock (CC.Block.ABOBBoundary ebb) _ _) = condenseABoundaryBlock ebb condenseABlock :: CC.Block.ABlock ByteString -> String @@ -578,17 +578,17 @@ condenseABoundaryHeader hdr = Left _ -> "Genesis" Right h -> sformat CC.Block.headerHashF h -instance Condense (Header ByronBlockOrEBB) where +instance Condense (Header ByronBlock) where condense (ByronHeaderRegular hdr _ (ByronHash hdrHash)) = condenseAHeader hdr hdrHash condense (ByronHeaderBoundary hdr _ _) = condenseABoundaryHeader hdr -instance Condense (ChainHash ByronBlockOrEBB) where +instance Condense (ChainHash ByronBlock) where condense GenesisHash = "genesis" condense (BlockHash h) = condense h -instance Condense (GenTx ByronBlockOrEBB) where +instance Condense (GenTx ByronBlock) where condense (ByronTx _ tx) = "byrontx: " <> T.unpack (sformat build (void tx)) condense (ByronDlg _ cert) = @@ -598,16 +598,16 @@ instance Condense (GenTx ByronBlockOrEBB) where condense (ByronUpdateVote _ vote) = "byronupdatevote: " <> T.unpack (sformat build (void vote)) -instance Show (GenTx ByronBlockOrEBB) where +instance Show (GenTx ByronBlock) where show tx = condense tx -instance Condense (GenTxId ByronBlockOrEBB) where +instance Condense (GenTxId ByronBlock) where condense (ByronTxId i) = "byrontxid: " <> condense i condense (ByronDlgId i) = "byrondlgid: " <> condense i condense (ByronUpdateProposalId i) = "byronupdateproposalid: " <> condense i condense (ByronUpdateVoteId i) = "byronupdatevoteid: " <> condense i -instance Show (GenTxId ByronBlockOrEBB) where +instance Show (GenTxId ByronBlock) where show = condense {------------------------------------------------------------------------------- @@ -616,7 +616,7 @@ instance Show (GenTxId ByronBlockOrEBB) where -- | Encode a block. A legacy Byron node (cardano-sl) would successfully -- decode a block from these. -encodeByronBlock :: ByronBlockOrEBB -> Encoding +encodeByronBlock :: ByronBlock -> Encoding encodeByronBlock blk = CBOR.encodeListLen 2 <> case bbRaw blk of @@ -631,16 +631,16 @@ encodeByronBlock blk = -- | Inversion of 'encodeByronBlock'. The annotation will be correct, because -- the full bytes are passed to the decoded value. decodeByronBlock :: CC.Slot.EpochSlots - -> Decoder s (Lazy.ByteString -> ByronBlockOrEBB) + -> Decoder s (Lazy.ByteString -> ByronBlock) decodeByronBlock epochSlots = fillInByteString <$> CC.Block.fromCBORABlockOrBoundary epochSlots where - fillInByteString it theBytes = mkByronBlockOrEBB epochSlots $ + fillInByteString it theBytes = mkByronBlock epochSlots $ Lazy.toStrict . slice theBytes <$> it -- | Encode a header. A legacy Byron node (cardano-sl) would successfully -- decode a header from these. -encodeByronHeader :: Header ByronBlockOrEBB -> Encoding +encodeByronHeader :: Header ByronBlock -> Encoding encodeByronHeader (ByronHeaderBoundary ebb _ _) = mconcat [ CBOR.encodeListLen 2 , CBOR.encodeWord 0 @@ -655,35 +655,35 @@ encodeByronHeader (ByronHeaderRegular mb _ _) = mconcat [ -- | Inversion of 'encodeByronHeader'. The annotation will be correct, because -- the full bytes are passed to the decoded value. decodeByronHeader :: CC.Slot.EpochSlots - -> Decoder s (Lazy.ByteString -> Header ByronBlockOrEBB) + -> Decoder s (Lazy.ByteString -> Header ByronBlock) decodeByronHeader epochSlots = fillInByteString <$> fromCBORAHeaderOrBoundary epochSlots where - fillInByteString it theBytes = mkByronHeaderOrEBB epochSlots $ bimap + fillInByteString it theBytes = mkByronHeader epochSlots $ bimap (fmap (Lazy.toStrict . slice theBytes)) (fmap (Lazy.toStrict . slice theBytes)) it -encodeByronHeaderHash :: HeaderHash ByronBlockOrEBB -> Encoding +encodeByronHeaderHash :: HeaderHash ByronBlock -> Encoding encodeByronHeaderHash = toCBOR -encodeByronLedgerState :: LedgerState ByronBlockOrEBB -> Encoding +encodeByronLedgerState :: LedgerState ByronBlock -> Encoding encodeByronLedgerState ByronLedgerState{..} = mconcat [ CBOR.encodeListLen 2 , encode blsCurrent , encode blsSnapshots ] -encodeByronChainState :: ChainState (BlockProtocol ByronBlockOrEBB) -> Encoding +encodeByronChainState :: ChainState (BlockProtocol ByronBlock) -> Encoding encodeByronChainState = encode -decodeByronHeaderHash :: Decoder s (HeaderHash ByronBlockOrEBB) +decodeByronHeaderHash :: Decoder s (HeaderHash ByronBlock) decodeByronHeaderHash = fromCBOR -encodeByronGenTx :: GenTx ByronBlockOrEBB -> Encoding +encodeByronGenTx :: GenTx ByronBlock -> Encoding encodeByronGenTx genTx = toCBOR (mkMempoolPayload genTx) -encodeByronGenTxId :: GenTxId ByronBlockOrEBB -> Encoding +encodeByronGenTxId :: GenTxId ByronBlock -> Encoding encodeByronGenTxId genTxId = case genTxId of ByronTxId i -> CBOR.encodeListLen 2 <> toCBOR (0 :: Word8) <> toCBOR i @@ -694,7 +694,7 @@ encodeByronGenTxId genTxId = case genTxId of ByronUpdateVoteId i -> CBOR.encodeListLen 2 <> toCBOR (3 :: Word8) <> toCBOR i -encodeByronApplyTxError :: ApplyTxErr ByronBlockOrEBB -> Encoding +encodeByronApplyTxError :: ApplyTxErr ByronBlock -> Encoding encodeByronApplyTxError = toCBOR -- | The 'ByteString' annotation will be the canonical encoding. @@ -710,7 +710,7 @@ encodeByronApplyTxError = toCBOR -- 'CC.UTxO.ATxAux', the transaction witness) matches the annotated -- bytestring. Is therefore __important__ that the annotated bytestring be the -- /canonical/ encoding, not the /original, possibly non-canonical/ encoding. -decodeByronGenTx :: Decoder s (GenTx ByronBlockOrEBB) +decodeByronGenTx :: Decoder s (GenTx ByronBlock) decodeByronGenTx = mkByronGenTx . canonicalise <$> fromCBOR where -- Fill in the 'ByteString' annotation with a canonical encoding of the @@ -728,25 +728,25 @@ decodeByronGenTx = mkByronGenTx . canonicalise <$> fromCBOR -- the canonical encoding's 'ByteSpan'. mp' = unsafeDeserialize canonicalBytes -decodeByronGenTxId :: Decoder s (GenTxId ByronBlockOrEBB) +decodeByronGenTxId :: Decoder s (GenTxId ByronBlock) decodeByronGenTxId = do - enforceSize "GenTxId (ByronBlockOrEBB cfg)" 2 + enforceSize "GenTxId (ByronBlock cfg)" 2 CBOR.decodeWord8 >>= \case 0 -> ByronTxId <$> fromCBOR 1 -> ByronDlgId <$> fromCBOR 2 -> ByronUpdateProposalId <$> fromCBOR 3 -> ByronUpdateVoteId <$> fromCBOR - tag -> cborError $ DecoderErrorUnknownTag "GenTxId (ByronBlockOrEBB cfg)" tag + tag -> cborError $ DecoderErrorUnknownTag "GenTxId (ByronBlock cfg)" tag -decodeByronLedgerState :: Decoder s (LedgerState ByronBlockOrEBB) +decodeByronLedgerState :: Decoder s (LedgerState ByronBlock) decodeByronLedgerState = do CBOR.decodeListLenOf 2 ByronLedgerState <$> decode <*> decode -decodeByronChainState :: Decoder s (ChainState (BlockProtocol ByronBlockOrEBB)) +decodeByronChainState :: Decoder s (ChainState (BlockProtocol ByronBlock)) decodeByronChainState = decode -decodeByronApplyTxError :: Decoder s (ApplyTxErr ByronBlockOrEBB) +decodeByronApplyTxError :: Decoder s (ApplyTxErr ByronBlock) decodeByronApplyTxError = fromCBOR {------------------------------------------------------------------------------- @@ -843,10 +843,10 @@ instance FromCBOR ByronApplyTxError where 3 -> ByronApplyUpdateVoteError <$> fromCBOR tag -> cborError $ DecoderErrorUnknownTag "ByronApplyTxError" tag -instance ApplyTx ByronBlockOrEBB where +instance ApplyTx ByronBlock where -- | Generalized transactions in Byron -- - data GenTx ByronBlockOrEBB + data GenTx ByronBlock = ByronTx CC.UTxO.TxId -- ^ This field is lazy on purpose so that the 'CC.UTxO.TxId' is @@ -869,7 +869,7 @@ instance ApplyTx ByronBlockOrEBB where !(CC.Update.Vote.AVote ByteString) deriving (Eq) - data GenTxId ByronBlockOrEBB + data GenTxId ByronBlock = ByronTxId !CC.UTxO.TxId | ByronDlgId !CC.Delegation.CertificateId | ByronUpdateProposalId !CC.Update.Proposal.UpId @@ -905,7 +905,7 @@ instance ApplyTx ByronBlockOrEBB where => f a -> ByteString canonicalEnc = CBOR.toStrictByteString . toCBOR . void - type ApplyTxErr ByronBlockOrEBB = ByronApplyTxError + type ApplyTxErr ByronBlock = ByronApplyTxError applyTx = applyByronGenTx (ValidationMode CC.Block.BlockValidation CC.UTxO.TxValidation) @@ -920,8 +920,8 @@ instance ApplyTx ByronBlockOrEBB where Right st' -> st' -- | We intentionally ignore the hash -instance NoUnexpectedThunks (GenTx ByronBlockOrEBB) where - showTypeOf _ = show (typeRep (Proxy @(GenTx ByronBlockOrEBB))) +instance NoUnexpectedThunks (GenTx ByronBlock) where + showTypeOf _ = show (typeRep (Proxy @(GenTx ByronBlock))) whnfNoUnexpectedThunks ctxt gtx = case gtx of ByronTx _hash tx -> noUnexpectedThunks ctxt (UseIsNormalFormNamed @"AVote" tx) @@ -933,11 +933,11 @@ instance NoUnexpectedThunks (GenTx ByronBlockOrEBB) where noUnexpectedThunks ctxt (UseIsNormalFormNamed @"AVote" vote) applyByronGenTx :: ValidationMode - -> LedgerConfig ByronBlockOrEBB - -> GenTx ByronBlockOrEBB - -> LedgerState ByronBlockOrEBB - -> Except (ApplyTxErr ByronBlockOrEBB) - (LedgerState ByronBlockOrEBB) + -> LedgerConfig ByronBlock + -> GenTx ByronBlock + -> LedgerState ByronBlock + -> Except (ApplyTxErr ByronBlock) + (LedgerState ByronBlock) applyByronGenTx validationMode (ByronLedgerConfig cfg) genTx @@ -946,7 +946,7 @@ applyByronGenTx validationMode <$> go genTx blsCurrent where go :: (MonadError ByronApplyTxError m) - => GenTx ByronBlockOrEBB + => GenTx ByronBlock -> CC.Block.ChainValidationState -> m CC.Block.ChainValidationState go gtx cvs = case gtx of @@ -1030,7 +1030,7 @@ applyByronGenTx validationMode `wrapError` ByronApplyUpdateVoteError mkByronGenTx :: CC.Mempool.AMempoolPayload ByteString - -> GenTx ByronBlockOrEBB + -> GenTx ByronBlock mkByronGenTx mp = case mp of CC.Mempool.MempoolTx tx@CC.UTxO.ATxAux{aTaTx} -> ByronTx (Crypto.hashDecoded aTaTx) tx -- TODO replace this with a @@ -1046,7 +1046,7 @@ mkByronGenTx mp = case mp of CC.Mempool.MempoolUpdateVote vote -> ByronUpdateVote (CC.Update.Vote.recoverVoteId vote) vote -mkMempoolPayload :: GenTx ByronBlockOrEBB +mkMempoolPayload :: GenTx ByronBlock -> CC.Mempool.AMempoolPayload ByteString mkMempoolPayload genTx = case genTx of ByronTx _ tx -> CC.Mempool.MempoolTx tx @@ -1059,14 +1059,14 @@ mkMempoolPayload genTx = case genTx of -------------------------------------------------------------------------------} -- | Check if a block matches its header -byronBlockOrEBBMatchesHeader :: Header ByronBlockOrEBB - -> ByronBlockOrEBB - -> Bool -byronBlockOrEBBMatchesHeader blkOrEbbHdr (ByronBlockOrEBB blkOrEbb _ _) = - case (blkOrEbbHdr, blkOrEbb) of - (ByronHeaderRegular hdr _ _, CC.Block.ABOBBlock blk) -> isRight $ - CC.Block.validateHeaderMatchesBody hdr (CC.Block.blockBody blk) - (ByronHeaderBoundary _ebbHdr _ _, CC.Block.ABOBBoundary _) -> +byronBlockMatchesHeader :: Header ByronBlock + -> ByronBlock + -> Bool +byronBlockMatchesHeader hdr (ByronBlock blk _ _) = + case (hdr, blk) of + (ByronHeaderRegular hdr' _ _, CC.Block.ABOBBlock blk') -> isRight $ + CC.Block.validateHeaderMatchesBody hdr' (CC.Block.blockBody blk') + (ByronHeaderBoundary _hdr' _ _, CC.Block.ABOBBoundary _) -> -- For EBBs, we're currently being more permissive here and not -- performing any header-body validation but only checking whether an -- EBB header and EBB block were provided. This seems to be fine as it @@ -1079,7 +1079,7 @@ byronBlockOrEBBMatchesHeader blkOrEbbHdr (ByronBlockOrEBB blkOrEbb _ _) = PBFT integration -------------------------------------------------------------------------------} -instance ProtocolLedgerView ByronBlockOrEBB where +instance ProtocolLedgerView ByronBlock where protocolLedgerView _ns (ByronLedgerState ls _) = pbftLedgerView ls diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Forge.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Forge.hs index 6810b669946..1cdf9d5cfbf 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Forge.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Forge.hs @@ -3,8 +3,8 @@ {-# LANGUAGE ScopedTypeVariables #-} module Ouroboros.Consensus.Ledger.Byron.Forge ( - forgeBlock - , forgeBlockOrEBB + forgeByronBlock + , forgeRegularBlock -- * For testing purposes , forgeGenesisEBB ) where @@ -36,7 +36,7 @@ import Ouroboros.Consensus.Protocol.PBFT import Ouroboros.Consensus.Ledger.Byron.Config -forgeBlockOrEBB +forgeByronBlock :: forall m. ( HasNodeState_ () m -- @()@ is the @NodeState@ of PBFT , MonadRandom m @@ -44,20 +44,20 @@ forgeBlockOrEBB => NodeConfig ByronConsensusProtocol -> SlotNo -- ^ Current slot -> BlockNo -- ^ Current block number - -> ChainHash ByronBlockOrEBB -- ^ Previous hash - -> [GenTx ByronBlockOrEBB] -- ^ Txs to add in the block + -> ChainHash ByronBlock -- ^ Previous hash + -> [GenTx ByronBlock] -- ^ Txs to add in the block -> PBftIsLeader PBftCardanoCrypto -- ^ Leader proof ('IsLeader') - -> m ByronBlockOrEBB -forgeBlockOrEBB cfg curSlot curNo prevHash txs isLeader = case prevHash of + -> m ByronBlock +forgeByronBlock cfg curSlot curNo prevHash txs isLeader = case prevHash of GenesisHash -> return $ forgeGenesisEBB cfg curSlot - BlockHash _ -> forgeBlock cfg curSlot curNo prevHash txs isLeader + BlockHash _ -> forgeRegularBlock cfg curSlot curNo prevHash txs isLeader forgeGenesisEBB :: NodeConfig ByronConsensusProtocol -> SlotNo - -> ByronBlockOrEBB + -> ByronBlock forgeGenesisEBB cfg curSlot = - mkByronBlockOrEBB pbftEpochSlots + mkByronBlock pbftEpochSlots . CC.Block.ABOBBoundary . annotateBoundary protocolMagicId $ boundaryBlock @@ -89,7 +89,7 @@ forgeGenesisEBB cfg curSlot = . CC.Slot.fromSlotNumber pbftEpochSlots $ coerce curSlot --- | Internal helper data type for 'forgeBlock' used to accumulate the +-- | Internal helper data type for 'forgeRegularBlock' used to accumulate the -- different kinds of block payloads that can be found in a given collection -- of Byron 'GenTx's. -- @@ -114,7 +114,7 @@ initBlockPayloads = BlockPayloads , bpUpProposal = Nothing } -forgeBlock +forgeRegularBlock :: forall m. ( HasNodeState_ () m -- @()@ is the @NodeState@ of PBFT , MonadRandom m @@ -122,11 +122,11 @@ forgeBlock => NodeConfig ByronConsensusProtocol -> SlotNo -- ^ Current slot -> BlockNo -- ^ Current block number - -> ChainHash ByronBlockOrEBB -- ^ Previous hash - -> [GenTx ByronBlockOrEBB] -- ^ Txs to add in the block + -> ChainHash ByronBlock -- ^ Previous hash + -> [GenTx ByronBlock] -- ^ Txs to add in the block -> PBftIsLeader PBftCardanoCrypto -- ^ Leader proof ('IsLeader') - -> m ByronBlockOrEBB -forgeBlock cfg curSlot curNo prevHash txs isLeader = do + -> m ByronBlock +forgeRegularBlock cfg curSlot curNo prevHash txs isLeader = do ouroborosPayload <- forgePBftFields cfg isLeader (reAnnotate $ Annotated toSign ()) return $ forge ouroborosPayload @@ -153,7 +153,7 @@ forgeBlock cfg curSlot curNo prevHash txs isLeader = do updatePayload = CC.Update.payload (bpUpProposal blockPayloads) (bpUpVotes blockPayloads) - extendBlockPayloads :: GenTx ByronBlockOrEBB + extendBlockPayloads :: GenTx ByronBlock -> BlockPayloads -> BlockPayloads extendBlockPayloads genTx bp@BlockPayloads{bpTxs, bpDlgCerts, bpUpVotes} = @@ -206,7 +206,7 @@ forgeBlock cfg curSlot curNo prevHash txs isLeader = do dlgCertificate = pbftDlgCert isLeader forge :: PBftFields PBftCardanoCrypto (Annotated CC.Block.ToSign ByteString) - -> ByronBlockOrEBB + -> ByronBlock forge ouroborosPayload = annotateByronBlock pbftEpochSlots block where diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node/ProtocolInfo/Byron.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/ProtocolInfo/Byron.hs index 2ce21acbc89..46ef7b3292a 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node/ProtocolInfo/Byron.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node/ProtocolInfo/Byron.hs @@ -109,7 +109,7 @@ protocolInfoByron :: Genesis.Config -> Update.ProtocolVersion -> Update.SoftwareVersion -> Maybe PBftLeaderCredentials - -> ProtocolInfo ByronBlockOrEBB + -> ProtocolInfo ByronBlock protocolInfoByron genesisConfig@Genesis.Config { Genesis.configGenesisHash = genesisHash , Genesis.configGenesisData = diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Byron.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Byron.hs index ebfc8016754..1f3006a7a66 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Byron.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Byron.hs @@ -27,9 +27,9 @@ import Ouroboros.Storage.Common (EpochSize (..)) RunNode instance -------------------------------------------------------------------------------} -instance RunNode ByronBlockOrEBB where - nodeForgeBlock = forgeBlockOrEBB - nodeBlockMatchesHeader = byronBlockOrEBBMatchesHeader +instance RunNode ByronBlock where + nodeForgeBlock = forgeByronBlock + nodeBlockMatchesHeader = byronBlockMatchesHeader nodeBlockFetchSize = const 2000 -- TODO #593 nodeIsEBB = \blk -> case bbRaw blk of Cardano.Block.ABOBBlock _ -> False diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol.hs index 3f2ff9c3650..88dd3ae8989 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol.hs @@ -81,7 +81,7 @@ data Protocol blk where -> Update.ProtocolVersion -> Update.SoftwareVersion -> Maybe PBftLeaderCredentials - -> Protocol ByronBlockOrEBB + -> Protocol ByronBlock {------------------------------------------------------------------------------- Evidence that we can run all the supported protocols diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/Ledger/Byron.hs b/ouroboros-consensus/test-consensus/Test/Consensus/Ledger/Byron.hs index 9e418693d4e..28fb26bd76e 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/Ledger/Byron.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/Ledger/Byron.hs @@ -117,31 +117,31 @@ annotate encode decoder = Serialisation roundtrips -------------------------------------------------------------------------------} -prop_roundtrip_Block :: Block -> Property +prop_roundtrip_Block :: ByronBlock -> Property prop_roundtrip_Block b = roundtrip' encodeByronBlock (decodeByronBlock epochSlots) b -prop_roundtrip_Header :: Header Block -> Property +prop_roundtrip_Header :: Header ByronBlock -> Property prop_roundtrip_Header h = roundtrip' encodeByronHeader (decodeByronHeader epochSlots) h -prop_roundtrip_HeaderHash :: HeaderHash Block -> Property +prop_roundtrip_HeaderHash :: HeaderHash ByronBlock -> Property prop_roundtrip_HeaderHash = roundtrip encodeByronHeaderHash decodeByronHeaderHash -prop_roundtrip_ChainState :: ChainState (BlockProtocol Block) -> Property +prop_roundtrip_ChainState :: ChainState (BlockProtocol ByronBlock) -> Property prop_roundtrip_ChainState = roundtrip encodeByronChainState decodeByronChainState -prop_roundtrip_GenTx :: GenTx Block -> Property +prop_roundtrip_GenTx :: GenTx ByronBlock -> Property prop_roundtrip_GenTx = roundtrip encodeByronGenTx decodeByronGenTx -prop_roundtrip_GenTxId :: GenTxId Block -> Property +prop_roundtrip_GenTxId :: GenTxId ByronBlock -> Property prop_roundtrip_GenTxId = roundtrip encodeByronGenTxId decodeByronGenTxId -prop_roundtrip_ApplyTxErr :: ApplyTxErr Block -> Property +prop_roundtrip_ApplyTxErr :: ApplyTxErr ByronBlock -> Property prop_roundtrip_ApplyTxErr = roundtrip encodeByronApplyTxError decodeByronApplyTxError @@ -149,46 +149,44 @@ prop_roundtrip_ApplyTxErr = Generators -------------------------------------------------------------------------------} -type Block = ByronBlockOrEBB - epochSlots :: EpochSlots epochSlots = EpochSlots 2160 protocolMagicId :: ProtocolMagicId protocolMagicId = ProtocolMagicId 100 -instance Arbitrary Block where +instance Arbitrary ByronBlock where arbitrary = frequency [ (3, genBlock) , (1, genBoundaryBlock) ] where - genBlock :: Gen Block + genBlock :: Gen ByronBlock genBlock = annotateByronBlock epochSlots <$> hedgehog (CC.genBlock protocolMagicId epochSlots) - genBoundaryBlock :: Gen Block + genBoundaryBlock :: Gen ByronBlock genBoundaryBlock = - mkByronBlockOrEBB epochSlots . ABOBBoundary . annotateBoundary protocolMagicId <$> + mkByronBlock epochSlots . ABOBBoundary . annotateBoundary protocolMagicId <$> hedgehog (CC.genBoundaryBlock) -instance Arbitrary (Header Block) where +instance Arbitrary (Header ByronBlock) where arbitrary = frequency [ (3, genHeader) , (1, genBoundaryHeader) ] where - genHeader :: Gen (Header Block) + genHeader :: Gen (Header ByronBlock) genHeader = - mkByronHeaderOrEBB epochSlots . Right . + mkByronHeader epochSlots . Right . annotate (CC.Block.toCBORHeader epochSlots) (CC.Block.fromCBORAHeader epochSlots) <$> hedgehog (CC.genHeader protocolMagicId epochSlots) - genBoundaryHeader :: Gen (Header Block) + genBoundaryHeader :: Gen (Header ByronBlock) genBoundaryHeader = - mkByronHeaderOrEBB epochSlots . Left . + mkByronHeader epochSlots . Left . annotate (CC.Block.toCBORABoundaryHeader protocolMagicId) CC.Block.fromCBORABoundaryHeader <$> @@ -204,12 +202,12 @@ instance Arbitrary (PBftChainState PBftCardanoCrypto) where arbitrary = fromMap <$> oneof [return Origin, At <$> arbitrary] <*> arbitrary -instance Arbitrary (GenTx Block) where +instance Arbitrary (GenTx ByronBlock) where arbitrary = mkByronGenTx . annotate toCBOR fromCBOR <$> hedgehog (CC.genMempoolPayload protocolMagicId) -instance Arbitrary (GenTxId Block) where +instance Arbitrary (GenTxId ByronBlock) where arbitrary = oneof [ ByronTxId <$> hedgehog CC.genTxId , ByronDlgId <$> hedgehog genCertificateId diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/RealPBFT.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/RealPBFT.hs index bfa9128c091..ffddebf7a62 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/RealPBFT.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/RealPBFT.hs @@ -23,7 +23,7 @@ import Ouroboros.Network.MockChain.Chain (Chain) import qualified Ouroboros.Network.MockChain.Chain as Chain import Ouroboros.Consensus.BlockchainTime -import Ouroboros.Consensus.Ledger.Byron (ByronBlockOrEBB) +import Ouroboros.Consensus.Ledger.Byron (ByronBlock) import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.ProtocolInfo.Byron (plcCoreNodeId) import Ouroboros.Consensus.NodeId @@ -114,7 +114,7 @@ prop_simple_real_pbft_convergence genesisConfig genesisSecrets)) testConfig seed - finalChains :: [Chain ByronBlockOrEBB] + finalChains :: [Chain ByronBlock] finalChains = Map.elems $ nodeOutputFinalChain <$> testOutputNodes testOutput genesisConfig :: Genesis.Config @@ -126,7 +126,7 @@ mkProtocolRealPBFT :: NumCoreNodes -> CoreNodeId -> Genesis.Config -> Genesis.GeneratedSecrets - -> Protocol ByronBlockOrEBB + -> Protocol ByronBlock mkProtocolRealPBFT (NumCoreNodes n) (CoreNodeId i) genesisConfig genesisSecrets = ProtocolRealPBFT diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/TxGen.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/TxGen.hs index 28f05c0302e..d607133e782 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/TxGen.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/TxGen.hs @@ -86,10 +86,10 @@ genSimpleTx addrs u = do Just x -> return x {------------------------------------------------------------------------------- - TxGen ByronBlockOrEBB + TxGen ByronBlock -------------------------------------------------------------------------------} -instance TxGen ByronBlockOrEBB where +instance TxGen ByronBlock where testGenTx = error "TODO #855 testGenTx" -- 'testGenTxs' is used by the tests, not 'testGenTx'. testGenTxs _ _ _ = return [] diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/ImmDB.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/ImmDB.hs index abd1d2f04b2..8bbdd66b06b 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/ImmDB.hs +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/ImmDB.hs @@ -20,7 +20,7 @@ import qualified Cardano.Chain.Update as Update import Ouroboros.Network.Block (SlotNo (..), blockHash, blockPoint) import Ouroboros.Consensus.Block (BlockProtocol) -import Ouroboros.Consensus.Ledger.Byron (ByronBlockOrEBB) +import Ouroboros.Consensus.Ledger.Byron (ByronBlock) import Ouroboros.Consensus.Ledger.Byron.Forge (forgeGenesisEBB) import Ouroboros.Consensus.Node.ProtocolInfo (NumCoreNodes (..), PBftSignatureThreshold (..), ProtocolInfo (..), @@ -59,22 +59,18 @@ test_getBlockWithPoint_EBB_at_tip = where ebb = forgeGenesisEBB testCfg (SlotNo 0) -withImmDB :: forall m blk a. - ( IOLike m - , blk ~ ByronBlockOrEBB - ) - => (ImmDB m blk -> m a) -> m a +withImmDB :: IOLike m => (ImmDB m ByronBlock -> m a) -> m a withImmDB k = do immDbFsVar <- uncheckedNewTVarM Mock.empty - epochInfo <- newEpochInfo $ nodeEpochSize (Proxy @blk) testCfg + epochInfo <- newEpochInfo $ nodeEpochSize (Proxy @ByronBlock) testCfg bracket (ImmDB.openDB (mkArgs immDbFsVar epochInfo)) ImmDB.closeDB k where mkArgs immDbFsVar epochInfo = ImmDbArgs { immErr = EH.monadCatch , immHasFS = simHasFS EH.monadCatch immDbFsVar - , immDecodeHash = nodeDecodeHeaderHash (Proxy @blk) + , immDecodeHash = nodeDecodeHeaderHash (Proxy @ByronBlock) , immDecodeBlock = nodeDecodeBlock testCfg - , immEncodeHash = nodeEncodeHeaderHash (Proxy @blk) + , immEncodeHash = nodeEncodeHeaderHash (Proxy @ByronBlock) , immEncodeBlock = nodeEncodeBlock testCfg , immEpochInfo = epochInfo , immValidation = ValidateMostRecentEpoch @@ -84,7 +80,7 @@ withImmDB k = do , immTracer = nullTracer } -testCfg :: NodeConfig (BlockProtocol ByronBlockOrEBB) +testCfg :: NodeConfig (BlockProtocol ByronBlock) testCfg = pInfoConfig $ protocolInfo (NumCoreNodes 1) prot where prot = ProtocolRealPBFT diff --git a/ouroboros-consensus/tools/db-analyse/Main.hs b/ouroboros-consensus/tools/db-analyse/Main.hs index c3b1554367d..1347e7fdb52 100644 --- a/ouroboros-consensus/tools/db-analyse/Main.hs +++ b/ouroboros-consensus/tools/db-analyse/Main.hs @@ -22,7 +22,7 @@ import qualified Cardano.Crypto as Crypto import Ouroboros.Network.Block (HasHeader (..), SlotNo (..), genesisPoint) -import Ouroboros.Consensus.Ledger.Byron (ByronBlockOrEBB, ByronHash) +import Ouroboros.Consensus.Ledger.Byron (ByronBlock, ByronHash) import qualified Ouroboros.Consensus.Ledger.Byron as Byron import Ouroboros.Consensus.Node.Run.Abstract import Ouroboros.Consensus.Node.Run.Byron () @@ -52,7 +52,7 @@ data AnalysisName = ShowSlotBlockNo | CountTxOutputs -type Analysis = ImmDB IO Blk +type Analysis = ImmDB IO ByronBlock -> EpochInfo IO -> ResourceRegistry IO -> IO () @@ -69,7 +69,7 @@ showSlotBlockNo :: Analysis showSlotBlockNo immDB _epochInfo rr = processAll immDB rr go where - go :: Either EpochNo SlotNo -> Blk -> IO () + go :: Either EpochNo SlotNo -> ByronBlock -> IO () go isEBB blk = putStrLn $ intercalate "\t" [ show isEBB , show (blockNo blk) @@ -85,10 +85,10 @@ countTxOutputs immDB epochInfo rr = do cumulative <- newIORef 0 processAll immDB rr (go cumulative) where - go :: IORef Int -> Either EpochNo SlotNo -> Blk -> IO () + go :: IORef Int -> Either EpochNo SlotNo -> ByronBlock -> IO () go cumulative isEBB blk = case (isEBB, blk) of - (Right slotNo, Byron.ByronBlockOrEBB (Chain.ABOBBlock regularBlk) _ _) -> + (Right slotNo, Byron.ByronBlock (Chain.ABOBBlock regularBlk) _ _) -> go' cumulative slotNo regularBlk _otherwise -> return () -- Skip EBBs @@ -136,15 +136,15 @@ relativeSlotNo epochInfo (SlotNo absSlot) = do Auxiliary: processing all blocks in the imm DB -------------------------------------------------------------------------------} -processAll :: ImmDB IO Blk +processAll :: ImmDB IO ByronBlock -> ResourceRegistry IO - -> (Either EpochNo SlotNo -> Blk -> IO ()) + -> (Either EpochNo SlotNo -> ByronBlock -> IO ()) -> IO () processAll immDB rr callback = do Right itr <- streamBlocksFrom immDB rr $ StreamFromExclusive genesisPoint go itr where - go :: Iterator ByronHash IO Blk -> IO () + go :: Iterator ByronHash IO ByronBlock -> IO () go itr = do itrResult <- ImmDB.iteratorNext itr case itrResult of @@ -222,12 +222,10 @@ openGenesis configFile onMainNet = do Interface with the ImmDB -------------------------------------------------------------------------------} -type Blk = ByronBlockOrEBB - -openImmDB :: FilePath -> EpochSlots -> EpochInfo IO -> IO (ImmDB IO Blk) +openImmDB :: FilePath -> EpochSlots -> EpochInfo IO -> IO (ImmDB IO ByronBlock) openImmDB fp epochSlots epochInfo = openDB args where - args :: ImmDbArgs IO Blk + args :: ImmDbArgs IO ByronBlock args = (defaultArgs fp) { immDecodeHash = Byron.decodeByronHeaderHash , immDecodeBlock = Byron.decodeByronBlock epochSlots diff --git a/ouroboros-consensus/tools/db-convert/Main.hs b/ouroboros-consensus/tools/db-convert/Main.hs index 9231c19eebc..b744fb1b80e 100644 --- a/ouroboros-consensus/tools/db-convert/Main.hs +++ b/ouroboros-consensus/tools/db-convert/Main.hs @@ -40,7 +40,7 @@ import Data.Typeable (Typeable) import Data.Word (Word64) import qualified Options.Applicative as Options import Options.Generic -import Ouroboros.Consensus.Ledger.Byron (ByronBlockOrEBB) +import Ouroboros.Consensus.Ledger.Byron (ByronBlock) import qualified Ouroboros.Consensus.Ledger.Byron as Byron import Ouroboros.Consensus.Node.ProtocolInfo.Abstract (pInfoConfig, pInfoInitLedger) @@ -146,7 +146,7 @@ convertEpochFile convertEpochFile es inFile outDir = let inStream = CC.parseEpochFileWithBoundary es (toFilePath inFile) dbDir = outDir [reldir|immutable|] - encode = CB.serializeEncoding' . Byron.encodeByronBlock . Byron.mkByronBlockOrEBB es + encode = CB.serializeEncoding' . Byron.encodeByronBlock . Byron.mkByronBlock es in do createDirIfMissing True dbDir -- Old filename format is XXXXX.dat, new is epoch-XXX.dat @@ -158,8 +158,7 @@ convertEpochFile es inFile outDir = runResourceT $ runExceptT $ S.mapM_ (liftIO . BS.hPut h) . S.map encode $ inStream validateChainDb - :: forall blk. (blk ~ ByronBlockOrEBB) - => Path Abs Dir -- ^ DB directory + :: Path Abs Dir -- ^ DB directory -> CC.Genesis.Config -> Bool -- Immutable DB only? -> Bool -- Verbose @@ -198,7 +197,7 @@ validateChainDb dbDir cfg onlyImmDB verbose = securityParam = SecurityParam $ CC.unBlockCount k k = CC.Genesis.configK cfg args registry = - (ChainDB.defaultArgs @blk (toFilePath dbDir)) + (ChainDB.defaultArgs @ByronBlock (toFilePath dbDir)) { ChainDB.cdbGenesis = return $ pInfoInitLedger byronProtocolInfo , ChainDB.cdbDecodeBlock = Byron.decodeByronBlock epochSlots , ChainDB.cdbDecodeChainState = Byron.decodeByronChainState From b0067518c7ef1c34d10867a80575f2819fe115ca Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Mon, 4 Nov 2019 15:28:41 +0100 Subject: [PATCH 2/2] Cleanup the Byron integration --- ouroboros-consensus/ouroboros-consensus.cabal | 7 + .../Ouroboros/Consensus/ChainSyncClient.hs | 8 +- .../Ouroboros/Consensus/Ledger/Abstract.hs | 5 +- .../src/Ouroboros/Consensus/Ledger/Byron.hs | 1165 +---------------- .../Ouroboros/Consensus/Ledger/Byron/Aux.hs | 614 +++++++++ .../Ouroboros/Consensus/Ledger/Byron/Block.hs | 250 ++++ .../Consensus/Ledger/Byron/ContainsGenesis.hs | 6 +- .../Consensus/Ledger/Byron/Conversions.hs | 40 + .../Ledger/Byron/DelegationHistory.hs | 175 +++ .../Ouroboros/Consensus/Ledger/Byron/Forge.hs | 15 +- .../Consensus/Ledger/Byron/Ledger.hs | 316 +++++ .../Consensus/Ledger/Byron/Mempool.hs | 253 ++++ .../Consensus/Ledger/Byron/Orphans.hs | 123 +- .../Ouroboros/Consensus/Ledger/Byron/PBFT.hs | 77 ++ .../Ouroboros/Consensus/Ledger/Extended.hs | 17 + .../Ouroboros/Consensus/Ledger/Mock/Block.hs | 4 - .../Consensus/Ledger/Mock/Block/BFT.hs | 2 +- .../Consensus/Ledger/Mock/Block/PBFT.hs | 2 +- .../Consensus/Ledger/Mock/Block/Praos.hs | 2 +- .../Consensus/Ledger/Mock/Block/PraosRule.hs | 2 +- .../Consensus/Node/ProtocolInfo/Byron.hs | 7 +- .../src/Ouroboros/Consensus/Node/Run/Byron.hs | 8 +- .../src/Ouroboros/Consensus/NodeKernel.hs | 4 + .../src/Ouroboros/Consensus/Protocol.hs | 1 - .../src/Ouroboros/Consensus/Util/Condense.hs | 76 +- .../Ouroboros/Consensus/Util/SlotBounded.hs | 72 +- .../Test/Consensus/Ledger/Byron.hs | 47 +- .../Test/Ouroboros/Storage/TestBlock.hs | 2 +- .../test-util/Test/Util/TestBlock.hs | 2 +- ouroboros-consensus/tools/db-convert/Main.hs | 2 +- 30 files changed, 2037 insertions(+), 1267 deletions(-) create mode 100644 ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Aux.hs create mode 100644 ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Block.hs create mode 100644 ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Conversions.hs create mode 100644 ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/DelegationHistory.hs create mode 100644 ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Ledger.hs create mode 100644 ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Mempool.hs create mode 100644 ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/PBFT.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 345c10d8d9f..29c5ac648c6 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -34,10 +34,17 @@ library Ouroboros.Consensus.Crypto.DSIGN.Cardano Ouroboros.Consensus.Ledger.Abstract Ouroboros.Consensus.Ledger.Byron + Ouroboros.Consensus.Ledger.Byron.Aux + Ouroboros.Consensus.Ledger.Byron.Block Ouroboros.Consensus.Ledger.Byron.Config Ouroboros.Consensus.Ledger.Byron.ContainsGenesis + Ouroboros.Consensus.Ledger.Byron.Conversions + Ouroboros.Consensus.Ledger.Byron.DelegationHistory Ouroboros.Consensus.Ledger.Byron.Forge + Ouroboros.Consensus.Ledger.Byron.Ledger + Ouroboros.Consensus.Ledger.Byron.Mempool Ouroboros.Consensus.Ledger.Byron.Orphans + Ouroboros.Consensus.Ledger.Byron.PBFT Ouroboros.Consensus.Ledger.Extended Ouroboros.Consensus.Ledger.Mock Ouroboros.Consensus.Ledger.Mock.Address diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs b/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs index 1f1a14a03ce..55f87bdccce 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs @@ -58,6 +58,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Util +import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.MonadSTM.NormalForm (checkInvariant, unsafeNoThunks) @@ -665,8 +666,13 @@ chainSyncClient mkPipelineDecision0 getTipBlockNo tracer cfg btime } Left TooFarAhead -> retry Right view -> case view `SB.at` hdrSlot of - Nothing -> error "anachronisticProtocolLedgerView invariant violated" Just lv -> return lv + Nothing -> error $ mconcat [ + "anachronisticProtocolLedgerView invariant violated: " + , condense hdrSlot + , " not within bounds " + , condense (SB.bounds view) + ] where hdrSlot = case pointSlot hdrPoint of Origin -> SlotNo 0 diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs index 718873387fa..762dcfd3fea 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableSuperClasses #-} @@ -21,7 +22,7 @@ import Ouroboros.Network.Point (WithOrigin) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Protocol.Abstract -import Ouroboros.Consensus.Util.SlotBounded (SlotBounded) +import Ouroboros.Consensus.Util.SlotBounded (Bounds (..), SlotBounded) {------------------------------------------------------------------------------- Interaction with the ledger layer @@ -127,7 +128,7 @@ class UpdateLedger blk => ProtocolLedgerView blk where :: NodeConfig (BlockProtocol blk) -> LedgerState blk -> WithOrigin SlotNo -- ^ Slot for which you would like a ledger view - -> Either AnachronyFailure (SlotBounded (LedgerView (BlockProtocol blk))) + -> Either AnachronyFailure (SlotBounded IX (LedgerView (BlockProtocol blk))) -- | See 'anachronisticProtocolLedgerView'. data AnachronyFailure diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs index 718e75c3874..81976cec8d5 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs @@ -1,1150 +1,19 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTSyntax #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module Ouroboros.Consensus.Ledger.Byron - ( -- * Byron blocks and headers - ByronHash (..) - , annotateByronBlock - -- * Mempool integration - , GenTx (..) - , GenTxId (..) - , ByronApplyTxError (..) - , mkByronGenTx - -- * Block Fetch integration - , byronBlockMatchesHeader - -- * Ledger - , LedgerState (..) - , LedgerConfig (..) - -- * Config - , ByronConsensusProtocol - -- * Serialisation - , encodeByronHeader - , encodeByronBlock - , encodeByronHeaderHash - , encodeByronGenTx - , encodeByronGenTxId - , encodeByronLedgerState - , encodeByronChainState - , encodeByronApplyTxError - , decodeByronHeader - , decodeByronBlock - , decodeByronHeaderHash - , decodeByronGenTx - , decodeByronGenTxId - , decodeByronLedgerState - , decodeByronChainState - , decodeByronApplyTxError - -- When adding a new en/decoder, add a test for it in - -- Test.Consensus.Ledger.Byron - - -- * EBBs - , ByronBlock(..) - , pattern ByronHeaderRegular - , pattern ByronHeaderBoundary - , mkByronHeader - , mkByronBlock - , annotateBoundary - , fromCBORAHeaderOrBoundary +module Ouroboros.Consensus.Ledger.Byron ( + module X ) where -import Cardano.Prelude (Word32, Word8, cborError, wrapError) - -import Codec.CBOR.Decoding (Decoder) -import qualified Codec.CBOR.Decoding as CBOR -import Codec.CBOR.Encoding (Encoding) -import qualified Codec.CBOR.Encoding as CBOR -import qualified Codec.CBOR.Read as CBOR -import qualified Codec.CBOR.Write as CBOR -import Codec.Serialise (decode, encode) -import Control.Monad.Except -import Control.Monad.Trans.Reader (runReaderT) -import Data.Bifunctor (bimap) -import qualified Data.Bimap as Bimap -import qualified Data.ByteString as Strict -import qualified Data.ByteString.Lazy as Lazy -import Data.Coerce (coerce) -import Data.Either (isRight) -import Data.FingerTree.Strict (Measured (..)) -import Data.Foldable (find, foldl') -import qualified Data.Sequence.Strict as Seq -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.Text as T -import Data.Typeable -import Formatting -import GHC.Generics (Generic) - -import Cardano.Binary (Annotated (..), ByteSpan, Decoded (..), - DecoderError (..), FromCBOR (..), ToCBOR (..), - enforceSize, fromCBOR, reAnnotate, serialize, slice, - toCBOR, unsafeDeserialize) -import qualified Cardano.Chain.Block as CC.Block -import qualified Cardano.Chain.Common as CC.Common -import qualified Cardano.Chain.Delegation as CC.Delegation -import qualified Cardano.Chain.Delegation.Validation.Interface as V.Interface -import qualified Cardano.Chain.Delegation.Validation.Scheduling as V.Scheduling -import qualified Cardano.Chain.Genesis as CC.Genesis -import qualified Cardano.Chain.MempoolPayload as CC.Mempool -import qualified Cardano.Chain.Slotting as CC.Slot -import qualified Cardano.Chain.Update.Proposal as CC.Update.Proposal -import qualified Cardano.Chain.Update.Validation.Interface as CC.UPI -import qualified Cardano.Chain.Update.Vote as CC.Update.Vote -import qualified Cardano.Chain.UTxO as CC.UTxO -import Cardano.Chain.ValidationMode (ValidationMode (..), - fromBlockValidationMode) -import qualified Cardano.Crypto as Crypto -import Cardano.Crypto.DSIGN -import Cardano.Crypto.Hash -import Cardano.Prelude (NoUnexpectedThunks (..), - UseIsNormalFormNamed (..)) - -import Ouroboros.Network.Block -import Ouroboros.Network.Point (WithOrigin (..)) -import qualified Ouroboros.Network.Point as Point (block, origin) - -import Ouroboros.Consensus.Block -import Ouroboros.Consensus.Crypto.DSIGN.Cardano -import Ouroboros.Consensus.Ledger.Abstract -import Ouroboros.Consensus.Ledger.Byron.Config -import Ouroboros.Consensus.Ledger.Byron.ContainsGenesis -import Ouroboros.Consensus.Ledger.Byron.Orphans () -import Ouroboros.Consensus.Mempool.API -import Ouroboros.Consensus.Protocol.Abstract -import Ouroboros.Consensus.Protocol.PBFT -import Ouroboros.Consensus.Util.Condense -import Ouroboros.Consensus.Util.SlotBounded (SlotBounded (..)) -import qualified Ouroboros.Consensus.Util.SlotBounded as SB - -type ByronConsensusProtocol = PBft ByronConfig PBftCardanoCrypto - -{------------------------------------------------------------------------------- - Header hash --------------------------------------------------------------------------------} - -newtype ByronHash = ByronHash { unByronHash :: CC.Block.HeaderHash } - deriving stock (Eq, Ord, Show, Generic) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass NoUnexpectedThunks - -instance Condense ByronHash where - condense = formatToString CC.Block.headerHashF . unByronHash - -{------------------------------------------------------------------------------- - Ledger --------------------------------------------------------------------------------} - -pbftLedgerView :: CC.Block.ChainValidationState - -> PBftLedgerView PBftCardanoCrypto -pbftLedgerView = PBftLedgerView - . CC.Delegation.unMap - . V.Interface.delegationMap - . CC.Block.cvsDelegationState - -allowedDelegators :: CC.Genesis.Config -> Set CC.Common.KeyHash -allowedDelegators - = CC.Genesis.unGenesisKeyHashes - . CC.Genesis.configGenesisKeyHashes - -{------------------------------------------------------------------------------- - Auxiliary --------------------------------------------------------------------------------} - -convertSlot :: CC.Slot.SlotNumber -> SlotNo -convertSlot = coerce - -{------------------------------------------------------------------------------- - Epoch Boundary Blocks --------------------------------------------------------------------------------} - -data ByronBlock = ByronBlock - { bbRaw :: !(CC.Block.ABlockOrBoundary ByteString) - , bbSlotNo :: !SlotNo - , bbHash :: !ByronHash - } deriving (Eq, Show) - --- | Internal: construct @Header ByronBlock@ with known hash --- --- This is useful when we are constructing a header from a @ByronBlock@, where --- we cache the cache. --- --- NOTE: The @slotNo@ should correspond to the one that we can compute from the --- header (using 'computeHeaderSlot') -- except we can't actually /do/ that --- conversion here since we'd need the know @epochSlots@ for that. -mkByronHeader' :: SlotNo - -> ByronHash - -> Either (CC.Block.ABoundaryHeader ByteString) - (CC.Block.AHeader ByteString) - -> Header ByronBlock -mkByronHeader' slotNo hdrHash header = case header of - Left ebb -> ByronHeaderBoundary ebb slotNo hdrHash - Right mb -> ByronHeaderRegular mb slotNo hdrHash - -mkByronHash :: Either (CC.Block.ABoundaryHeader ByteString) - (CC.Block.AHeader ByteString) - -> ByronHash -mkByronHash (Left ebb) = ByronHash $ CC.Block.boundaryHeaderHashAnnotated ebb -mkByronHash (Right mb) = ByronHash $ CC.Block.headerHashAnnotated mb - -mkByronHeader :: CC.Slot.EpochSlots - -> Either (CC.Block.ABoundaryHeader ByteString) - (CC.Block.AHeader ByteString) - -> Header ByronBlock -mkByronHeader epochSlots header = - mkByronHeader' slotNo hdrHash header - where - slotNo = computeHeaderSlot epochSlots header - hdrHash = mkByronHash header - --- | Internal: compute the slot number of a Byron header -computeHeaderSlot :: CC.Slot.EpochSlots - -> Either (CC.Block.ABoundaryHeader a) (CC.Block.AHeader a) - -> SlotNo -computeHeaderSlot _ (Right hdr) = - convertSlot $ CC.Block.headerSlot hdr -computeHeaderSlot epochSlots (Left hdr) = - SlotNo $ CC.Slot.unEpochSlots epochSlots * CC.Block.boundaryEpoch hdr - -instance GetHeader ByronBlock where - data Header ByronBlock = - ByronHeaderRegular !(CC.Block.AHeader ByteString) !SlotNo !ByronHash - | ByronHeaderBoundary !(CC.Block.ABoundaryHeader ByteString) !SlotNo !ByronHash - deriving (Eq, Show, Generic) - - getHeader (ByronBlock (CC.Block.ABOBBlock b) slotNo hdrHash) = - ByronHeaderRegular (CC.Block.blockHeader b) slotNo hdrHash - getHeader (ByronBlock (CC.Block.ABOBBoundary b) slotNo hdrHash) = - ByronHeaderBoundary (CC.Block.boundaryHeader b) slotNo hdrHash - -type instance HeaderHash ByronBlock = ByronHash - -instance NoUnexpectedThunks (Header ByronBlock) where - showTypeOf _ = show $ typeRep (Proxy @(Header ByronBlock)) - -instance SupportedBlock ByronBlock - -instance HasHeader ByronBlock where - blockHash = blockHash . getHeader - blockPrevHash = castHash . blockPrevHash . getHeader - blockSlot = blockSlot . getHeader - blockNo = blockNo . getHeader - blockInvariant = const True - -instance HasHeader (Header ByronBlock) where - blockHash (ByronHeaderRegular _ _ h) = h - blockHash (ByronHeaderBoundary _ _ h) = h - - blockPrevHash (ByronHeaderRegular mb _ _) = - BlockHash . ByronHash . CC.Block.headerPrevHash $ mb - blockPrevHash (ByronHeaderBoundary ebb _ _) = - case CC.Block.boundaryPrevHash ebb of - Left _ -> GenesisHash - Right h -> BlockHash (ByronHash h) - - blockSlot (ByronHeaderRegular _ slotNo _) = slotNo - blockSlot (ByronHeaderBoundary _ slotNo _) = slotNo - - blockNo (ByronHeaderRegular mb _ _) = - BlockNo - . CC.Common.unChainDifficulty - . CC.Block.headerDifficulty - $ mb - blockNo (ByronHeaderBoundary ebb _ _) = - BlockNo - . CC.Common.unChainDifficulty - . CC.Block.boundaryDifficulty - $ ebb - - blockInvariant = const True - -instance Measured BlockMeasure ByronBlock where - measure = blockMeasure - -instance StandardHash ByronBlock - -instance HeaderSupportsPBft ByronConfig PBftCardanoCrypto (Header ByronBlock) where - type OptSigned (Header ByronBlock) = Annotated CC.Block.ToSign ByteString - - headerPBftFields _ (ByronHeaderBoundary{}) = Nothing - headerPBftFields cfg (ByronHeaderRegular hdr _ _) = Just ( - PBftFields { - pbftIssuer = VerKeyCardanoDSIGN - . CC.Delegation.delegateVK - . CC.Block.delegationCertificate - . CC.Block.headerSignature - $ hdr - , pbftGenKey = VerKeyCardanoDSIGN - . CC.Block.headerGenesisKey - $ hdr - , pbftSignature = SignedDSIGN - . SigCardanoDSIGN - . CC.Block.signature - . CC.Block.headerSignature - $ hdr - } - , CC.Block.recoverSignedBytes epochSlots hdr - ) - where - epochSlots = pbftEpochSlots $ pbftExtConfig cfg - -type instance BlockProtocol ByronBlock = ByronConsensusProtocol - -instance UpdateLedger ByronBlock where - - data LedgerState ByronBlock = ByronLedgerState - { blsCurrent :: !CC.Block.ChainValidationState - -- | Slot-bounded snapshots of the chain state - , blsSnapshots :: !(Seq.StrictSeq (SlotBounded (PBftLedgerView PBftCardanoCrypto))) - } - deriving (Eq, Show, Generic) - - type LedgerError ByronBlock = CC.Block.ChainValidationError - - newtype LedgerConfig ByronBlock = ByronLedgerConfig { - unByronLedgerConfig :: CC.Genesis.Config - } - - ledgerConfigView PBftNodeConfig{..} = ByronLedgerConfig $ - pbftGenesisConfig pbftExtConfig - - applyChainTick (ByronLedgerConfig cfg) slotNo - (ByronLedgerState state snapshots) = do - let updateState' = CC.Block.epochTransition - epochEnv - (CC.Block.cvsUpdateState state) - (coerce slotNo) - let state' = state { CC.Block.cvsUpdateState = updateState' } - return $ ByronLedgerState state' snapshots - where - epochEnv = CC.Block.EpochEnvironment - { CC.Block.protocolMagic = fixPMI $ CC.Genesis.configProtocolMagicId cfg - , CC.Block.k = CC.Genesis.configK cfg - , CC.Block.allowedDelegators = allowedDelegators cfg - , CC.Block.delegationMap = delegationMap - , CC.Block.currentEpoch = CC.Slot.slotNumberEpoch - (CC.Genesis.configEpochSlots cfg) - (CC.Block.cvsLastSlot state) - } - delegationMap = V.Interface.delegationMap - $ CC.Block.cvsDelegationState state - - fixPMI pmi = reAnnotate $ Annotated pmi () - - applyLedgerBlock = applyByronLedgerBlock - (fromBlockValidationMode CC.Block.BlockValidation) - - reapplyLedgerBlock cfg blk st = - let validationMode = fromBlockValidationMode CC.Block.NoBlockValidation - -- Given a 'BlockValidationMode' of 'NoBlockValidation', a call to - -- 'applyByronLedgerBlock' shouldn't fail since the ledger layer - -- won't be performing any block validation checks. - -- However, because 'applyByronLedgerBlock' can fail in the event it - -- is given a 'BlockValidationMode' of 'BlockValidation', it still /looks/ - -- like it can fail (since its type doesn't change based on the - -- 'ValidationMode') and we must still treat it as such. - in case runExcept (applyByronLedgerBlock validationMode cfg blk st) of - Left err -> error ("reapplyLedgerBlock: unexpected error: " <> show err) - Right st' -> st' - - ledgerTipPoint (ByronLedgerState state _) = case CC.Block.cvsPreviousHash state of - -- In this case there are no blocks in the ledger state. The genesis - -- block does not occupy a slot, so its point is Origin. - Left _genHash -> Point Point.origin - Right hdrHash -> Point (Point.block slot (ByronHash hdrHash)) - where - slot = convertSlot (CC.Block.cvsLastSlot state) - -instance NoUnexpectedThunks (LedgerState ByronBlock) - -- use generic instance - -instance ConfigContainsGenesis (LedgerConfig ByronBlock) where - genesisConfig = unByronLedgerConfig - -applyABlock :: ValidationMode - -> CC.Genesis.Config - -> CC.Block.ABlock ByteString - -> CC.Block.HeaderHash - -> LedgerState (ByronBlock) - -> Except (LedgerError ByronBlock) - (LedgerState ByronBlock) -applyABlock validationMode - cfg - block - blkHash - (ByronLedgerState state snapshots) = do - runReaderT - (CC.Block.headerIsValid - (CC.Block.cvsUpdateState state) - (CC.Block.blockHeader block) - ) - validationMode - CC.Block.BodyState { CC.Block.utxo, CC.Block.updateState - , CC.Block.delegationState } - <- runReaderT - (CC.Block.updateBody bodyEnv bodyState block) - validationMode - let state' = state - { CC.Block.cvsLastSlot = CC.Block.blockSlot block - , CC.Block.cvsPreviousHash = Right blkHash - , CC.Block.cvsUtxo = utxo - , CC.Block.cvsUpdateState = updateState - , CC.Block.cvsDelegationState = delegationState - } - snapshots' - | CC.Block.cvsDelegationState state' == - CC.Block.cvsDelegationState state - = snapshots - | otherwise - = snapshots Seq.|> - SB.bounded startOfSnapshot slot (pbftLedgerView state') - where - startOfSnapshot = case snapshots of - _ Seq.:|> a -> sbUpper a - Seq.Empty -> SlotNo 0 - slot = convertSlot $ CC.Block.blockSlot block - return $ ByronLedgerState state' (trimSnapshots snapshots') - where - bodyState = CC.Block.BodyState - { CC.Block.utxo = CC.Block.cvsUtxo state - , CC.Block.updateState = CC.Block.cvsUpdateState state - , CC.Block.delegationState = CC.Block.cvsDelegationState state - } - bodyEnv = CC.Block.BodyEnvironment - { CC.Block.protocolMagic = fixPM $ CC.Genesis.configProtocolMagic cfg - , CC.Block.utxoConfiguration = CC.Genesis.configUTxOConfiguration cfg - , CC.Block.k = CC.Genesis.configK cfg - , CC.Block.allowedDelegators = allowedDelegators cfg - , CC.Block.protocolParameters = protocolParameters - , CC.Block.currentEpoch = CC.Slot.slotNumberEpoch - (CC.Genesis.configEpochSlots cfg) - (CC.Block.blockSlot block) - } - - protocolParameters = CC.UPI.adoptedProtocolParameters . CC.Block.cvsUpdateState - $ state - - fixPM (Crypto.AProtocolMagic a b) = Crypto.AProtocolMagic (reAnnotate a) b - - k = CC.Genesis.configK cfg - - trimSnapshots = Seq.dropWhileL $ \ss -> - sbUpper ss < convertSlot (CC.Block.blockSlot block) - 2 * coerce k - -applyByronLedgerBlock :: ValidationMode - -> LedgerConfig ByronBlock - -> ByronBlock - -> LedgerState ByronBlock - -> Except (LedgerError ByronBlock) - (LedgerState ByronBlock) -applyByronLedgerBlock validationMode - (ByronLedgerConfig cfg) - (ByronBlock blk _ (ByronHash blkHash)) - bs@(ByronLedgerState state snapshots) = - case blk of - CC.Block.ABOBBlock b -> - applyABlock validationMode cfg b blkHash bs - CC.Block.ABOBBoundary b -> - return ByronLedgerState { - blsCurrent = state { - CC.Block.cvsPreviousHash = Right blkHash - , CC.Block.cvsLastSlot = CC.Slot.SlotNumber $ epochSlots * CC.Block.boundaryEpoch hdr - } - , blsSnapshots = snapshots - } - where - hdr = CC.Block.boundaryHeader b - CC.Slot.EpochSlots epochSlots = CC.Genesis.configEpochSlots cfg - -mkByronBlock :: CC.Slot.EpochSlots - -> CC.Block.ABlockOrBoundary ByteString - -> ByronBlock -mkByronBlock epochSlots blk = ByronBlock { - bbRaw = blk - , bbSlotNo = computeHeaderSlot epochSlots hdr - , bbHash = mkByronHash hdr - } - where - hdr = mkBlockOrBoundaryHeader blk - -mkBlockOrBoundaryHeader :: CC.Block.ABlockOrBoundary a - -> Either (CC.Block.ABoundaryHeader a) - (CC.Block.AHeader a) -mkBlockOrBoundaryHeader blk = case blk of - CC.Block.ABOBBlock blk' -> Right $ CC.Block.blockHeader blk' - CC.Block.ABOBBoundary blk' -> Left $ CC.Block.boundaryHeader blk' - --- | Construct Byron block from unannotated 'CC.Block.Block' --- --- This should be used only when forging blocks (not when receiving blocks --- over the wire). -annotateByronBlock :: CC.Slot.EpochSlots -> CC.Block.Block -> ByronBlock -annotateByronBlock epochSlots = - mkByronBlock epochSlots - . CC.Block.ABOBBlock - . annotateBlock epochSlots - -{------------------------------------------------------------------------------- - Condense instances --------------------------------------------------------------------------------} - -instance Condense ByronBlock where - condense (ByronBlock (CC.Block.ABOBBlock blk) _slotNo (ByronHash hdrHash)) = - "(header: " <> condenseAHeader (CC.Block.blockHeader blk) hdrHash <> - ", body: " <> condenseABlock blk <> - ")" - condense (ByronBlock (CC.Block.ABOBBoundary ebb) _ _) = - condenseABoundaryBlock ebb - -condenseABlock :: CC.Block.ABlock ByteString -> String -condenseABlock = T.unpack - . sformat build - . CC.UTxO.txpTxs - . CC.Block.bodyTxPayload - . CC.Block.blockBody - -condenseAHeader :: CC.Block.AHeader ByteString -> CC.Block.HeaderHash -> String -condenseAHeader hdr hdrHash = - "(hash: " <> condensedHash <> - ", previousHash: " <> condensedPrevHash <> - ", slot: " <> condensedSlot <> - ", issuer: " <> condenseKey issuer <> - ", delegate: " <> condenseKey delegate <> - ")" - where - psigCert = CC.Block.delegationCertificate - . CC.Block.headerSignature - $ hdr - issuer = CC.Delegation.issuerVK psigCert - delegate = CC.Delegation.delegateVK psigCert - - condenseKey :: Crypto.VerificationKey -> String - condenseKey = T.unpack . sformat build - - condensedHash - = T.unpack - . sformat CC.Block.headerHashF - $ hdrHash - - condensedPrevHash - = T.unpack - . sformat CC.Block.headerHashF - . CC.Block.headerPrevHash - $ hdr - - condensedSlot - = T.unpack - . sformat build - . unAnnotated - . CC.Block.aHeaderSlot - $ hdr - -condenseABoundaryBlock :: CC.Block.ABoundaryBlock ByteString -> String -condenseABoundaryBlock CC.Block.ABoundaryBlock{boundaryHeader} = - condenseABoundaryHeader boundaryHeader - -condenseABoundaryHeader :: CC.Block.ABoundaryHeader ByteString -> String -condenseABoundaryHeader hdr = - "( ebb: true" <> - ", hash: " <> condensedHash <> - ", previousHash: " <> condensedPrevHash <> - ")" - where - condensedHash - = T.unpack - . sformat CC.Block.headerHashF - . coerce - . Crypto.hashDecoded . fmap CC.Block.wrapBoundaryBytes - $ hdr - - condensedPrevHash - = T.unpack $ case CC.Block.boundaryPrevHash hdr of - Left _ -> "Genesis" - Right h -> sformat CC.Block.headerHashF h - -instance Condense (Header ByronBlock) where - condense (ByronHeaderRegular hdr _ (ByronHash hdrHash)) = - condenseAHeader hdr hdrHash - condense (ByronHeaderBoundary hdr _ _) = - condenseABoundaryHeader hdr - -instance Condense (ChainHash ByronBlock) where - condense GenesisHash = "genesis" - condense (BlockHash h) = condense h - -instance Condense (GenTx ByronBlock) where - condense (ByronTx _ tx) = - "byrontx: " <> T.unpack (sformat build (void tx)) - condense (ByronDlg _ cert) = - "byrondlg: " <> T.unpack (sformat build (void cert)) - condense (ByronUpdateProposal _ p) = - "byronupdateproposal: " <> T.unpack (sformat build (void p)) - condense (ByronUpdateVote _ vote) = - "byronupdatevote: " <> T.unpack (sformat build (void vote)) - -instance Show (GenTx ByronBlock) where - show tx = condense tx - -instance Condense (GenTxId ByronBlock) where - condense (ByronTxId i) = "byrontxid: " <> condense i - condense (ByronDlgId i) = "byrondlgid: " <> condense i - condense (ByronUpdateProposalId i) = "byronupdateproposalid: " <> condense i - condense (ByronUpdateVoteId i) = "byronupdatevoteid: " <> condense i - -instance Show (GenTxId ByronBlock) where - show = condense - -{------------------------------------------------------------------------------- - Serialisation --------------------------------------------------------------------------------} - --- | Encode a block. A legacy Byron node (cardano-sl) would successfully --- decode a block from these. -encodeByronBlock :: ByronBlock -> Encoding -encodeByronBlock blk = - CBOR.encodeListLen 2 - <> case bbRaw blk of - CC.Block.ABOBBoundary b -> - CBOR.encodeWord 0 - <> CBOR.encodePreEncoded (CC.Block.boundaryAnnotation b) - - CC.Block.ABOBBlock b -> - CBOR.encodeWord 1 - <> CBOR.encodePreEncoded (CC.Block.blockAnnotation b) - --- | Inversion of 'encodeByronBlock'. The annotation will be correct, because --- the full bytes are passed to the decoded value. -decodeByronBlock :: CC.Slot.EpochSlots - -> Decoder s (Lazy.ByteString -> ByronBlock) -decodeByronBlock epochSlots = - fillInByteString <$> CC.Block.fromCBORABlockOrBoundary epochSlots - where - fillInByteString it theBytes = mkByronBlock epochSlots $ - Lazy.toStrict . slice theBytes <$> it - --- | Encode a header. A legacy Byron node (cardano-sl) would successfully --- decode a header from these. -encodeByronHeader :: Header ByronBlock -> Encoding -encodeByronHeader (ByronHeaderBoundary ebb _ _) = mconcat [ - CBOR.encodeListLen 2 - , CBOR.encodeWord 0 - , CBOR.encodePreEncoded (CC.Block.boundaryHeaderAnnotation ebb) - ] -encodeByronHeader (ByronHeaderRegular mb _ _) = mconcat [ - CBOR.encodeListLen 2 - , CBOR.encodeWord 1 - , CBOR.encodePreEncoded (CC.Block.headerAnnotation mb) - ] - --- | Inversion of 'encodeByronHeader'. The annotation will be correct, because --- the full bytes are passed to the decoded value. -decodeByronHeader :: CC.Slot.EpochSlots - -> Decoder s (Lazy.ByteString -> Header ByronBlock) -decodeByronHeader epochSlots = - fillInByteString <$> fromCBORAHeaderOrBoundary epochSlots - where - fillInByteString it theBytes = mkByronHeader epochSlots $ bimap - (fmap (Lazy.toStrict . slice theBytes)) - (fmap (Lazy.toStrict . slice theBytes)) - it - -encodeByronHeaderHash :: HeaderHash ByronBlock -> Encoding -encodeByronHeaderHash = toCBOR - -encodeByronLedgerState :: LedgerState ByronBlock -> Encoding -encodeByronLedgerState ByronLedgerState{..} = mconcat - [ CBOR.encodeListLen 2 - , encode blsCurrent - , encode blsSnapshots - ] - -encodeByronChainState :: ChainState (BlockProtocol ByronBlock) -> Encoding -encodeByronChainState = encode - -decodeByronHeaderHash :: Decoder s (HeaderHash ByronBlock) -decodeByronHeaderHash = fromCBOR - -encodeByronGenTx :: GenTx ByronBlock -> Encoding -encodeByronGenTx genTx = toCBOR (mkMempoolPayload genTx) - -encodeByronGenTxId :: GenTxId ByronBlock -> Encoding -encodeByronGenTxId genTxId = case genTxId of - ByronTxId i -> - CBOR.encodeListLen 2 <> toCBOR (0 :: Word8) <> toCBOR i - ByronDlgId i -> - CBOR.encodeListLen 2 <> toCBOR (1 :: Word8) <> toCBOR i - ByronUpdateProposalId i -> - CBOR.encodeListLen 2 <> toCBOR (2 :: Word8) <> toCBOR i - ByronUpdateVoteId i -> - CBOR.encodeListLen 2 <> toCBOR (3 :: Word8) <> toCBOR i - -encodeByronApplyTxError :: ApplyTxErr ByronBlock -> Encoding -encodeByronApplyTxError = toCBOR - --- | The 'ByteString' annotation will be the canonical encoding. --- --- While the new implementation does not care about canonical encodings, the --- old one does. When a generalised transaction arrives that is not in its --- canonical encoding (only the 'CC.UTxO.ATxAux' of the 'ByronTx' can be --- produced by nodes that are not under our control), the old implementation --- will reject it. Therefore, we need to reject them too. See #905. --- --- We use the ledger to check for canonical encodings: the ledger will check --- whether the signed hash of the transaction (in the case of a --- 'CC.UTxO.ATxAux', the transaction witness) matches the annotated --- bytestring. Is therefore __important__ that the annotated bytestring be the --- /canonical/ encoding, not the /original, possibly non-canonical/ encoding. -decodeByronGenTx :: Decoder s (GenTx ByronBlock) -decodeByronGenTx = mkByronGenTx . canonicalise <$> fromCBOR - where - -- Fill in the 'ByteString' annotation with a canonical encoding of the - -- 'GenTx'. We must reserialise the deserialised 'GenTx' to be sure we - -- have the canonical one. We don't have access to the original - -- 'ByteString' anyway, so having to reserialise here gives us a - -- 'ByteString' we can use. - canonicalise :: CC.Mempool.AMempoolPayload ByteSpan - -> CC.Mempool.AMempoolPayload ByteString - canonicalise mp = Lazy.toStrict . slice canonicalBytes <$> mp' - where - canonicalBytes = serialize (void mp) - -- 'unsafeDeserialize' cannot fail, since we just 'serialize'd it. - -- Note that we cannot reuse @mp@, as its 'ByteSpan' might differ from - -- the canonical encoding's 'ByteSpan'. - mp' = unsafeDeserialize canonicalBytes - -decodeByronGenTxId :: Decoder s (GenTxId ByronBlock) -decodeByronGenTxId = do - enforceSize "GenTxId (ByronBlock cfg)" 2 - CBOR.decodeWord8 >>= \case - 0 -> ByronTxId <$> fromCBOR - 1 -> ByronDlgId <$> fromCBOR - 2 -> ByronUpdateProposalId <$> fromCBOR - 3 -> ByronUpdateVoteId <$> fromCBOR - tag -> cborError $ DecoderErrorUnknownTag "GenTxId (ByronBlock cfg)" tag - -decodeByronLedgerState :: Decoder s (LedgerState ByronBlock) -decodeByronLedgerState = do - CBOR.decodeListLenOf 2 - ByronLedgerState <$> decode <*> decode - -decodeByronChainState :: Decoder s (ChainState (BlockProtocol ByronBlock)) -decodeByronChainState = decode - -decodeByronApplyTxError :: Decoder s (ApplyTxErr ByronBlock) -decodeByronApplyTxError = fromCBOR - -{------------------------------------------------------------------------------- - Internal auxiliary - - TODO: This should live in an upstream repo instead. --------------------------------------------------------------------------------} - -annotateBlock :: CC.Slot.EpochSlots - -> CC.Block.ABlock () - -> CC.Block.ABlock ByteString -annotateBlock epochSlots = - (\bs -> splice bs (CBOR.deserialiseFromBytes - (CC.Block.fromCBORABlock epochSlots) - bs)) - . CBOR.toLazyByteString - . CC.Block.toCBORBlock epochSlots - where - splice :: Lazy.ByteString - -> Either err (Lazy.ByteString, CC.Block.ABlock ByteSpan) - -> CC.Block.ABlock ByteString - splice _ (Left _err) = - error "annotateBlock: serialization roundtrip failure" - splice bs (Right (_leftover, txAux)) = - (Lazy.toStrict . slice bs) <$> txAux - -{------------------------------------------------------------------------------- - Internal auxiliary - - Since we will not be creating further boundary blocks, these utilities do not - exist in the cardano-ledger repo, but we need them for the genesis case in the - demo. - -------------------------------------------------------------------------------} - -annotateBoundary :: Crypto.ProtocolMagicId - -> CC.Block.ABoundaryBlock () - -> CC.Block.ABoundaryBlock ByteString -annotateBoundary pm = - (\bs -> splice bs (CBOR.deserialiseFromBytes - CC.Block.fromCBORABoundaryBlock - bs)) - . CBOR.toLazyByteString - . CC.Block.toCBORABoundaryBlock pm - where - splice :: Show err - => Lazy.ByteString - -> Either err (Lazy.ByteString, CC.Block.ABoundaryBlock ByteSpan) - -> CC.Block.ABoundaryBlock ByteString - splice _ (Left err) = - error $ "annotateBoundary: serialization roundtrip failure: " <> show err - splice bs (Right (_leftover, boundary)) = - (Lazy.toStrict . slice bs) <$> boundary - -fromCBORAHeaderOrBoundary - :: CC.Slot.EpochSlots - -> Decoder s (Either (CC.Block.ABoundaryHeader ByteSpan) (CC.Block.AHeader ByteSpan)) -fromCBORAHeaderOrBoundary epochSlots = do - enforceSize "Block" 2 - fromCBOR @Word >>= \case - 0 -> Left <$> CC.Block.fromCBORABoundaryHeader - 1 -> Right <$> CC.Block.fromCBORAHeader epochSlots - t -> error $ "Unknown tag in encoded HeaderOrBoundary" <> show t - -{------------------------------------------------------------------------------- - Mempool integration --------------------------------------------------------------------------------} - --- | An error type which represents either a UTxO, delegation, update proposal --- registration, or update vote error in the Byron era. -data ByronApplyTxError - = ByronApplyTxError !CC.UTxO.UTxOValidationError - | ByronApplyDlgError !V.Scheduling.Error - | ByronApplyUpdateProposalError !CC.UPI.Error - | ByronApplyUpdateVoteError !CC.UPI.Error - deriving (Eq, Show) - -instance ToCBOR ByronApplyTxError where - toCBOR (ByronApplyTxError err) = - CBOR.encodeListLen 2 <> toCBOR (0 :: Word8) <> toCBOR err - toCBOR (ByronApplyDlgError err) = - CBOR.encodeListLen 2 <> toCBOR (1 :: Word8) <> toCBOR err - toCBOR (ByronApplyUpdateProposalError err) = - CBOR.encodeListLen 2 <> toCBOR (2 :: Word8) <> toCBOR err - toCBOR (ByronApplyUpdateVoteError err) = - CBOR.encodeListLen 2 <> toCBOR (3 :: Word8) <> toCBOR err - -instance FromCBOR ByronApplyTxError where - fromCBOR = do - enforceSize "ByronApplyTxError" 2 - CBOR.decodeWord8 >>= \case - 0 -> ByronApplyTxError <$> fromCBOR - 1 -> ByronApplyDlgError <$> fromCBOR - 2 -> ByronApplyUpdateProposalError <$> fromCBOR - 3 -> ByronApplyUpdateVoteError <$> fromCBOR - tag -> cborError $ DecoderErrorUnknownTag "ByronApplyTxError" tag - -instance ApplyTx ByronBlock where - -- | Generalized transactions in Byron - -- - data GenTx ByronBlock - = ByronTx - CC.UTxO.TxId - -- ^ This field is lazy on purpose so that the 'CC.UTxO.TxId' is - -- computed on demand. - !(CC.UTxO.ATxAux ByteString) - | ByronDlg - CC.Delegation.CertificateId - -- ^ This field is lazy on purpose so that the - -- 'CC.Delegation.CertificateId' is computed on demand. - !(CC.Delegation.ACertificate ByteString) - | ByronUpdateProposal - CC.Update.Proposal.UpId - -- ^ This field is lazy on purpose so that the 'CC.Update.UpId' is - -- computed on demand. - !(CC.Update.Proposal.AProposal ByteString) - | ByronUpdateVote - CC.Update.Vote.VoteId - -- ^ This field is lazy on purpose so that the 'CC.Update.VoteId' is - -- computed on demand. - !(CC.Update.Vote.AVote ByteString) - deriving (Eq) - - data GenTxId ByronBlock - = ByronTxId !CC.UTxO.TxId - | ByronDlgId !CC.Delegation.CertificateId - | ByronUpdateProposalId !CC.Update.Proposal.UpId - | ByronUpdateVoteId !CC.Update.Vote.VoteId - deriving (Eq, Ord) - - txId (ByronTx txid _) = ByronTxId txid - txId (ByronDlg certHash _) = ByronDlgId certHash - txId (ByronUpdateProposal upid _) = ByronUpdateProposalId upid - txId (ByronUpdateVote voteHash _) = ByronUpdateVoteId voteHash - - txSize genTx = 1 {- encodeListLen -} + 1 {- tag -} + case genTx of - ByronTx _ atxaux -> decodedLength atxaux - ByronDlg _ cert -> decodedLength cert - ByronUpdateProposal _ prop -> decodedLength prop - ByronUpdateVote _ vote -> decodedLength vote - where - decodedLength :: Decoded a => a -> Word32 - decodedLength = fromIntegral . Strict.length . recoverBytes - - -- Check that the annotation is the canonical encoding. This is currently - -- enforced by 'decodeByronGenTx', see its docstring for more context. - txInvariant genTx = case genTx of - ByronTx _ atxaux -> annotatedEnc atxaux == canonicalEnc atxaux - ByronDlg _ cert -> annotatedEnc cert == canonicalEnc cert - ByronUpdateProposal _ prop -> annotatedEnc prop == canonicalEnc prop - ByronUpdateVote _ vote -> annotatedEnc vote == canonicalEnc vote - where - annotatedEnc :: Decoded (f ByteString) - => f ByteString -> ByteString - annotatedEnc = recoverBytes - canonicalEnc :: (Functor f, ToCBOR (f ())) - => f a -> ByteString - canonicalEnc = CBOR.toStrictByteString . toCBOR . void - - type ApplyTxErr ByronBlock = ByronApplyTxError - - applyTx = applyByronGenTx - (ValidationMode CC.Block.BlockValidation CC.UTxO.TxValidation) - - reapplyTx = applyByronGenTx - (ValidationMode CC.Block.NoBlockValidation CC.UTxO.TxValidationNoCrypto) - - reapplyTxSameState cfg tx st = - let validationMode = ValidationMode CC.Block.NoBlockValidation CC.UTxO.NoTxValidation - in case runExcept (applyByronGenTx validationMode cfg tx st) of - Left err -> error $ "unexpected error: " <> show err - Right st' -> st' - --- | We intentionally ignore the hash -instance NoUnexpectedThunks (GenTx ByronBlock) where - showTypeOf _ = show (typeRep (Proxy @(GenTx ByronBlock))) - whnfNoUnexpectedThunks ctxt gtx = case gtx of - ByronTx _hash tx -> - noUnexpectedThunks ctxt (UseIsNormalFormNamed @"AVote" tx) - ByronDlg _hash cert -> - noUnexpectedThunks ctxt (UseIsNormalFormNamed @"ACertificate" cert) - ByronUpdateProposal _hash prop -> - noUnexpectedThunks ctxt (UseIsNormalFormNamed @"AProposal" prop) - ByronUpdateVote _hash vote -> - noUnexpectedThunks ctxt (UseIsNormalFormNamed @"AVote" vote) - -applyByronGenTx :: ValidationMode - -> LedgerConfig ByronBlock - -> GenTx ByronBlock - -> LedgerState ByronBlock - -> Except (ApplyTxErr ByronBlock) - (LedgerState ByronBlock) -applyByronGenTx validationMode - (ByronLedgerConfig cfg) - genTx - st@ByronLedgerState{blsCurrent} = - (\x -> st { blsCurrent = x }) - <$> go genTx blsCurrent - where - go :: (MonadError ByronApplyTxError m) - => GenTx ByronBlock - -> CC.Block.ChainValidationState - -> m CC.Block.ChainValidationState - go gtx cvs = case gtx of - ByronTx _ tx -> applyByronTx tx - ByronDlg _ cert -> applyByronDlg cert - ByronUpdateProposal _ proposal -> applyByronUpdateProposal proposal - ByronUpdateVote _ vote -> applyByronUpdateVote vote - where - protocolMagic = fixPM (CC.Genesis.configProtocolMagic cfg) - - k = CC.Genesis.configK cfg - - currentEpoch = CC.Slot.slotNumberEpoch - (CC.Genesis.configEpochSlots cfg) - currentSlot - - currentSlot = CC.Block.cvsLastSlot cvs - - utxo = CC.Block.cvsUtxo cvs - - dlgState = CC.Block.cvsDelegationState cvs - - updateState = CC.Block.cvsUpdateState cvs - - delegationMap = - (V.Interface.delegationMap . CC.Block.cvsDelegationState) cvs - - utxoEnv = CC.UTxO.Environment - { CC.UTxO.protocolMagic = protocolMagic - , CC.UTxO.protocolParameters = CC.UPI.adoptedProtocolParameters updateState - , CC.UTxO.utxoConfiguration = CC.Genesis.configUTxOConfiguration cfg - } - - dlgEnv = V.Interface.Environment - { V.Interface.protocolMagic = Crypto.getAProtocolMagicId protocolMagic - , V.Interface.allowedDelegators = allowedDelegators cfg - , V.Interface.k = k - , V.Interface.currentEpoch = currentEpoch - , V.Interface.currentSlot = currentSlot - } - - updateEnv = CC.UPI.Environment - { CC.UPI.protocolMagic = Crypto.getAProtocolMagicId protocolMagic - , CC.UPI.k = k - , CC.UPI.currentSlot = currentSlot - , CC.UPI.numGenKeys = numGenKeys - , CC.UPI.delegationMap = delegationMap - } - - numGenKeys = toNumGenKeys $ Set.size (allowedDelegators cfg) - - toNumGenKeys :: Integral n => n -> Word8 - toNumGenKeys n - | n > fromIntegral (maxBound :: Word8) = error $ - "toNumGenKeys: Too many genesis keys" - | otherwise = fromIntegral n - - fixPM (Crypto.AProtocolMagic a b) = - Crypto.AProtocolMagic (reAnnotate a) b - - wrapUTxO newUTxO = cvs { CC.Block.cvsUtxo = newUTxO } - - wrapDlg newDlg = cvs { CC.Block.cvsDelegationState = newDlg } - - wrapUpdate newUpdate = cvs { CC.Block.cvsUpdateState = newUpdate } - - applyByronTx tx = wrapUTxO <$> - runReaderT (CC.UTxO.updateUTxO utxoEnv utxo [tx]) validationMode - `wrapError` ByronApplyTxError - - applyByronDlg cert = wrapDlg <$> - V.Interface.updateDelegation dlgEnv dlgState [cert] - `wrapError` ByronApplyDlgError - - applyByronUpdateProposal proposal = wrapUpdate <$> - CC.UPI.registerProposal updateEnv updateState proposal - `wrapError` ByronApplyUpdateProposalError - - applyByronUpdateVote vote = wrapUpdate <$> - CC.UPI.registerVote updateEnv updateState vote - `wrapError` ByronApplyUpdateVoteError - -mkByronGenTx :: CC.Mempool.AMempoolPayload ByteString - -> GenTx ByronBlock -mkByronGenTx mp = case mp of - CC.Mempool.MempoolTx tx@CC.UTxO.ATxAux{aTaTx} -> - ByronTx (Crypto.hashDecoded aTaTx) tx -- TODO replace this with a - -- function from cardano-ledger, - -- see cardano-ledger#581 - - CC.Mempool.MempoolDlg cert -> - ByronDlg (CC.Delegation.recoverCertificateId cert) cert - - CC.Mempool.MempoolUpdateProposal proposal -> - ByronUpdateProposal (CC.Update.Proposal.recoverUpId proposal) proposal - - CC.Mempool.MempoolUpdateVote vote -> - ByronUpdateVote (CC.Update.Vote.recoverVoteId vote) vote - -mkMempoolPayload :: GenTx ByronBlock - -> CC.Mempool.AMempoolPayload ByteString -mkMempoolPayload genTx = case genTx of - ByronTx _ tx -> CC.Mempool.MempoolTx tx - ByronDlg _ cert -> CC.Mempool.MempoolDlg cert - ByronUpdateProposal _ proposal -> CC.Mempool.MempoolUpdateProposal proposal - ByronUpdateVote _ vote -> CC.Mempool.MempoolUpdateVote vote - -{------------------------------------------------------------------------------- - Block Fetch integration --------------------------------------------------------------------------------} - --- | Check if a block matches its header -byronBlockMatchesHeader :: Header ByronBlock - -> ByronBlock - -> Bool -byronBlockMatchesHeader hdr (ByronBlock blk _ _) = - case (hdr, blk) of - (ByronHeaderRegular hdr' _ _, CC.Block.ABOBBlock blk') -> isRight $ - CC.Block.validateHeaderMatchesBody hdr' (CC.Block.blockBody blk') - (ByronHeaderBoundary _hdr' _ _, CC.Block.ABOBBoundary _) -> - -- For EBBs, we're currently being more permissive here and not - -- performing any header-body validation but only checking whether an - -- EBB header and EBB block were provided. This seems to be fine as it - -- won't cause any loss of consensus with the old `cardano-sl` nodes. - True - (ByronHeaderRegular{} , CC.Block.ABOBBoundary{}) -> False - (ByronHeaderBoundary{} , CC.Block.ABOBBlock{}) -> False - -{------------------------------------------------------------------------------- - PBFT integration --------------------------------------------------------------------------------} - -instance ProtocolLedgerView ByronBlock where - protocolLedgerView _ns (ByronLedgerState ls _) = - pbftLedgerView ls - - -- There are two cases here: - -- - -- - The view we want is in the past. In this case, we attempt to find a - -- snapshot which contains the relevant slot, and extract the delegation - -- map from that. - -- - -- - The view we want is in the future. In this case, we need to check the - -- upcoming delegations to see what new delegations will be made in the - -- future, and update the current delegation map based on that. - anachronisticProtocolLedgerView - cfg - (ByronLedgerState ls ss) slot = - case find (containsSlot slot) ss of - -- We can find a snapshot which supports this slot - Just sb -> Right sb - -- No snapshot - we could be in the past or in the future - Nothing - | slot < At lvLB -> Left TooFarBehind - | slot > At lvUB -> Left TooFarAhead - | otherwise - -> Right $ PBftLedgerView <$> - case intermediateUpdates of - -- No updates to apply. So the current ledger state is valid - -- from the end of the last snapshot to the first scheduled - -- update. - Seq.Empty -> SB.bounded lb ub dsNow - -- Updates to apply. So we must apply them, and then the ledger - -- state is valid from the end of the last update until the next - -- scheduled update in the future. - toApply@(_ Seq.:|> la) -> - SB.bounded (convertSlot . V.Scheduling.sdSlot $ la) ub $ - foldl' - (\acc x -> Bimap.insert (V.Scheduling.sdDelegator x) - (V.Scheduling.sdDelegate x) - acc) - dsNow toApply - where - lb = case ss of - _ Seq.:|> s -> max lvLB (sbUpper s) - Seq.Empty -> lvLB - ub = case futureUpdates of - s Seq.:<| _ -> min lvUB (convertSlot $ V.Scheduling.sdSlot s) - Seq.Empty -> lvUB - - (intermediateUpdates, futureUpdates) = Seq.spanl - (\sd -> At (convertSlot (V.Scheduling.sdSlot sd)) <= slot) - dsScheduled - - SecurityParam paramK = pbftSecurityParam . pbftParams $ cfg - - lvUB = SlotNo $ unSlotNo currentSlot + (2 * paramK) - lvLB - | 2 * paramK > unSlotNo currentSlot - = SlotNo 0 - | otherwise - = SlotNo $ unSlotNo currentSlot - (2 * paramK) - - dsNow = pbftDelegates $ pbftLedgerView ls - dsScheduled = Seq.toStrict - . V.Scheduling.scheduledDelegations - . V.Interface.schedulingState - . CC.Block.cvsDelegationState - $ ls - currentSlot = convertSlot $ CC.Block.cvsLastSlot ls - containsSlot s sb = At (sbLower sb) <= s && At (sbUpper sb) >= s +-- Modules Aux, Conversions and Orphans are not re-exported, as they deal with +-- wrapping cardano-ledger; this should not be needed elsewhere in consensus. + +-- From DelegationHistory we only import the type, as this module is intended +-- to be imported qualified. + +import Ouroboros.Consensus.Ledger.Byron.Block as X +import Ouroboros.Consensus.Ledger.Byron.Config as X +import Ouroboros.Consensus.Ledger.Byron.ContainsGenesis as X +import Ouroboros.Consensus.Ledger.Byron.DelegationHistory as X + (DelegationHistory) +import Ouroboros.Consensus.Ledger.Byron.Forge as X +import Ouroboros.Consensus.Ledger.Byron.Ledger as X +import Ouroboros.Consensus.Ledger.Byron.Mempool as X +import Ouroboros.Consensus.Ledger.Byron.PBFT as X diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Aux.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Aux.hs new file mode 100644 index 00000000000..24c969e8de2 --- /dev/null +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Aux.hs @@ -0,0 +1,614 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Auxiliary definitions to make working with the Byron ledger easier +-- +-- NOTE: None of these definitions depend on @ouroboros-network@ or +-- @ouroboros-consensus@ and could probably be moved to @cardano-ledger@. +module Ouroboros.Consensus.Ledger.Byron.Aux ( + -- * Extract info from genesis config + allowedDelegators + , boundaryBlockSlot + -- * Extract info from chain state + , getDelegationMap + , getProtocolParams + , getScheduledDelegations + -- * Applying blocks + , applyEpochTransition + , validateBlock + , validateBoundary + , applyScheduledDelegations + -- * Applying transactions + , ApplyMempoolPayloadErr(..) + , applyMempoolPayload + , mempoolPayloadRecoverBytes + , mempoolPayloadReencode + -- * Annotations + , reAnnotateBlock + , reAnnotateBoundary + , reAnnotateUsing + -- * Headers + , ABlockOrBoundaryHdr(..) + , aBlockOrBoundaryHdr + , fromCBORABlockOrBoundaryHdr + , abobHdrFromBlock + , abobHdrSlotNo + , abobHdrChainDifficulty + , abobHdrHash + , abobHdrPrevHash + , abobMatchesBody + ) where + +import Codec.CBOR.Decoding (Decoder) +import qualified Codec.CBOR.Decoding as CBOR +import qualified Codec.CBOR.Encoding as CBOR +import qualified Codec.CBOR.Read as CBOR +import qualified Codec.CBOR.Write as CBOR +import Control.Monad.Except +import Control.Monad.Reader +import Data.Bimap (Bimap) +import qualified Data.Bimap as Bimap +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as Lazy +import Data.Either (isRight) +import qualified Data.Foldable as Foldable +import Data.List (intercalate) +import Data.Sequence (Seq) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Word +import GHC.Generics (Generic) + +import Cardano.Binary +import Cardano.Crypto.ProtocolMagic +import Cardano.Prelude (NoUnexpectedThunks, cborError, wrapError) + +import qualified Cardano.Chain.Block as CC +import qualified Cardano.Chain.Common as CC +import qualified Cardano.Chain.Delegation as Delegation +import qualified Cardano.Chain.Delegation.Validation.Interface as D.Iface +import qualified Cardano.Chain.Delegation.Validation.Scheduling as D.Sched +import qualified Cardano.Chain.Genesis as Gen +import qualified Cardano.Chain.MempoolPayload as CC +import qualified Cardano.Chain.Slotting as CC +import qualified Cardano.Chain.Update as Update +import qualified Cardano.Chain.Update.Validation.Interface as U.Iface +import qualified Cardano.Chain.UTxO as Utxo +import qualified Cardano.Chain.ValidationMode as CC + +-- NOTE: NO dependencies on ouroboros-network or ouroboros-consensus here! +-- This stuff could/should eventually be moved to cardano-ledger. + +{------------------------------------------------------------------------------- + Extract info from genesis config +-------------------------------------------------------------------------------} + +allowedDelegators :: Gen.Config -> Set CC.KeyHash +allowedDelegators = + Gen.unGenesisKeyHashes + . Gen.configGenesisKeyHashes + +-- | Compute the slot number assigned to a boundary block +boundaryBlockSlot :: CC.EpochSlots -> Word64 -> CC.SlotNumber +boundaryBlockSlot (CC.EpochSlots epochSlots) epoch = + CC.SlotNumber $ epochSlots * epoch + +{------------------------------------------------------------------------------- + Extract info from chain state +-------------------------------------------------------------------------------} + +getDelegationMap :: CC.ChainValidationState -> Delegation.Map +getDelegationMap = + D.Iface.delegationMap + . CC.cvsDelegationState + +getProtocolParams :: CC.ChainValidationState -> Update.ProtocolParameters +getProtocolParams = + U.Iface.adoptedProtocolParameters + . CC.cvsUpdateState + +getScheduledDelegations :: CC.ChainValidationState + -> Seq D.Sched.ScheduledDelegation +getScheduledDelegations = + D.Sched.scheduledDelegations + . D.Iface.schedulingState + . CC.cvsDelegationState + +{------------------------------------------------------------------------------- + Update parts of the chain state +-------------------------------------------------------------------------------} + +setUTxO :: Utxo.UTxO + -> CC.ChainValidationState -> CC.ChainValidationState +setUTxO newUTxO state = state { CC.cvsUtxo = newUTxO } + +setDelegationState :: D.Iface.State + -> CC.ChainValidationState -> CC.ChainValidationState +setDelegationState newDlg state = state { CC.cvsDelegationState = newDlg } + +setUpdateState :: U.Iface.State + -> CC.ChainValidationState -> CC.ChainValidationState +setUpdateState newUpdate state = state { CC.cvsUpdateState = newUpdate } + +{------------------------------------------------------------------------------- + Applying blocks +-------------------------------------------------------------------------------} + +mkEpochEnvironment :: Gen.Config + -> CC.ChainValidationState + -> CC.EpochEnvironment +mkEpochEnvironment cfg state = CC.EpochEnvironment { + CC.protocolMagic = reAnnotateMagicId $ + Gen.configProtocolMagicId cfg + , CC.k = Gen.configK cfg + , CC.allowedDelegators = allowedDelegators cfg + , CC.delegationMap = delegationMap + -- The 'currentEpoch' required by the epoch environment is the /old/ + -- epoch (i.e., the one in the ledger state), so that we can verify that + -- the new epoch indeed is after the old. + , CC.currentEpoch = CC.slotNumberEpoch + (Gen.configEpochSlots cfg) + (CC.cvsLastSlot state) + } + where + delegationMap :: Delegation.Map + delegationMap = D.Iface.delegationMap $ CC.cvsDelegationState state + +mkBodyState :: CC.ChainValidationState -> CC.BodyState +mkBodyState state = CC.BodyState { + CC.utxo = CC.cvsUtxo state + , CC.updateState = CC.cvsUpdateState state + , CC.delegationState = CC.cvsDelegationState state + } + +-- TODO: Unlike 'mkEpochEnvironment' and 'mkDelegationEnvironment', for the +-- body processing we set 'currentEpoch' to the epoch of the block rather than +-- the current epoch (in the state). Is that deliberate? +mkBodyEnvironment :: Gen.Config + -> Update.ProtocolParameters + -> CC.SlotNumber + -> CC.BodyEnvironment +mkBodyEnvironment cfg params slotNo = CC.BodyEnvironment { + CC.protocolMagic = reAnnotateMagic $ Gen.configProtocolMagic cfg + , CC.utxoConfiguration = Gen.configUTxOConfiguration cfg + , CC.k = Gen.configK cfg + , CC.allowedDelegators = allowedDelegators cfg + , CC.protocolParameters = params + -- The 'currentEpoch' for validating a block should be the /current/ + -- epoch (that is, the epoch of the block), /not/ the old epoch + -- (from the ledger state). This is to make sure delegation certificates + -- are for the /next/ epoch. + , CC.currentEpoch = CC.slotNumberEpoch + (Gen.configEpochSlots cfg) + slotNo + } + +applyEpochTransition :: Gen.Config + -> CC.SlotNumber + -> CC.ChainValidationState + -> CC.ChainValidationState +applyEpochTransition cfg slotNo state = state { + CC.cvsUpdateState = CC.epochTransition + (mkEpochEnvironment cfg state) + (CC.cvsUpdateState state) + slotNo + } + +-- | Validate header +-- +-- NOTE: Header validation does not produce any state changes; the only state +-- changes arising from processing headers come from 'applyEpochTransition'. +validateHeader :: MonadError CC.ChainValidationError m + => CC.ValidationMode + -> U.Iface.State -> CC.AHeader ByteString -> m () +validateHeader validationMode updState hdr = + flip runReaderT validationMode $ + CC.headerIsValid updState hdr + +validateBody :: MonadError CC.ChainValidationError m + => CC.ValidationMode + -> CC.ABlock ByteString + -> CC.BodyEnvironment -> CC.BodyState -> m CC.BodyState +validateBody validationMode block bodyEnv bodyState = + flip runReaderT validationMode $ + CC.updateBody bodyEnv bodyState block + +validateBlock :: MonadError CC.ChainValidationError m + => Gen.Config + -> CC.ValidationMode + -> CC.ABlock ByteString + -> CC.HeaderHash + -> CC.ChainValidationState -> m CC.ChainValidationState +validateBlock cfg validationMode block blkHash state = do + + -- TODO: How come this check isn't done in 'updateBlock' + -- (but it /is/ done in 'updateChainBoundary')? + -- + -- TODO: It could be argued that hash checking isn't part of consensus /or/ + -- the ledger. If we take that point of view serious, we should think about + -- what that third thing is precisely and what its responsibilities are. + case ( CC.cvsPreviousHash state + , unAnnotated $ CC.aHeaderPrevHash (CC.blockHeader block) + ) of + (Left gh, hh) -> + throwError $ CC.ChainValidationExpectedGenesisHash gh hh + (Right expected, actual) -> + unless (expected == actual) $ + throwError $ CC.ChainValidationInvalidHash expected actual + + validateHeader validationMode updState (CC.blockHeader block) + bodyState' <- validateBody validationMode block bodyEnv bodyState + return state { + CC.cvsLastSlot = CC.blockSlot block + , CC.cvsPreviousHash = Right blkHash + , CC.cvsUtxo = CC.utxo bodyState' + , CC.cvsUpdateState = CC.updateState bodyState' + , CC.cvsDelegationState = CC.delegationState bodyState' + } + where + updState = CC.cvsUpdateState state + bodyEnv = mkBodyEnvironment + cfg + (getProtocolParams state) + (CC.blockSlot block) + bodyState = mkBodyState state + +-- | Apply a boundary block +-- +-- NOTE: The `cvsLastSlot` calculation must match the one in 'abobHdrSlotNo'. +validateBoundary :: MonadError CC.ChainValidationError m + => Gen.Config + -> CC.ABoundaryBlock ByteString + -> CC.ChainValidationState -> m CC.ChainValidationState +validateBoundary cfg blk state = do + -- TODO: Unfortunately, 'updateChainBoundary' doesn't take a hash as an + -- argument but recomputes it. + state' <- CC.updateChainBoundary state blk + -- TODO: For some reason 'updateChainBoundary' does not set the slot when + -- applying an EBB, so we do it here. Could that cause problems?? + return state' { + CC.cvsLastSlot = boundaryBlockSlot epochSlots (CC.boundaryEpoch hdr) + } + where + hdr = CC.boundaryHeader blk + epochSlots = Gen.configEpochSlots cfg + +applyScheduledDelegations :: Seq D.Sched.ScheduledDelegation + -> Delegation.Map -> Delegation.Map +applyScheduledDelegations update (Delegation.Map del) = + -- The order in which we apply the updates does not matter, because the spec + -- says: "Any given key can issue at most one certificate in a given slot." + Delegation.Map $ Foldable.foldl' (flip applyOne) del update + where + applyOne :: D.Sched.ScheduledDelegation + -> Bimap CC.KeyHash CC.KeyHash + -> Bimap CC.KeyHash CC.KeyHash + applyOne x = Bimap.insert (D.Sched.sdDelegator x) + (D.Sched.sdDelegate x) + +{------------------------------------------------------------------------------- + Applying transactions +-------------------------------------------------------------------------------} + +mkUtxoEnvironment :: Gen.Config + -> CC.ChainValidationState + -> Utxo.Environment +mkUtxoEnvironment cfg state = Utxo.Environment { + Utxo.protocolMagic = protocolMagic + , Utxo.protocolParameters = U.Iface.adoptedProtocolParameters updateState + , Utxo.utxoConfiguration = Gen.configUTxOConfiguration cfg + } + where + protocolMagic = reAnnotateMagic (Gen.configProtocolMagic cfg) + updateState = CC.cvsUpdateState state + +mkDelegationEnvironment :: Gen.Config + -> CC.ChainValidationState + -> D.Iface.Environment +mkDelegationEnvironment cfg state = D.Iface.Environment { + D.Iface.protocolMagic = getAProtocolMagicId protocolMagic + , D.Iface.allowedDelegators = allowedDelegators cfg + , D.Iface.k = k + -- By rights the 'currentEpoch' for checking a delegation certificate + -- should be the epoch of the block in which the delegation certificate + -- is included. However, we don't have such a block yet, and so we can + -- only use the epoch from the ledger state. This does mean that we might + -- say a transaction is valid now, but will become invalid by the time we + -- actually include it in a block. + , D.Iface.currentEpoch = currentEpoch + , D.Iface.currentSlot = currentSlot + } + where + k = Gen.configK cfg + protocolMagic = reAnnotateMagic (Gen.configProtocolMagic cfg) + currentSlot = CC.cvsLastSlot state + currentEpoch = CC.slotNumberEpoch (Gen.configEpochSlots cfg) currentSlot + +mkUpdateEnvironment :: Gen.Config + -> CC.ChainValidationState + -> U.Iface.Environment +mkUpdateEnvironment cfg state = U.Iface.Environment { + U.Iface.protocolMagic = getAProtocolMagicId protocolMagic + , U.Iface.k = k + , U.Iface.currentSlot = currentSlot + , U.Iface.numGenKeys = numGenKeys + , U.Iface.delegationMap = delegationMap + } + where + k = Gen.configK cfg + protocolMagic = reAnnotateMagic (Gen.configProtocolMagic cfg) + currentSlot = CC.cvsLastSlot state + numGenKeys = toNumGenKeys $ Set.size (allowedDelegators cfg) + delegationMap = getDelegationMap state + + -- TODO: This function comes straight from cardano-ledger, which however + -- does not export it. We should either export it, or -- preferably -- when + -- all of the functions in this module are moved to cardano-ledger, the + -- function can just be used directly. + toNumGenKeys :: Int -> Word8 + toNumGenKeys n + | n > fromIntegral (maxBound :: Word8) = error $ + "toNumGenKeys: Too many genesis keys" + | otherwise = fromIntegral n + +applyTxAux :: MonadError Utxo.UTxOValidationError m + => CC.ValidationMode + -> Gen.Config + -> [Utxo.ATxAux ByteString] + -> CC.ChainValidationState -> m CC.ChainValidationState +applyTxAux validationMode cfg txs state = + flip runReaderT validationMode $ + (`setUTxO` state) <$> + Utxo.updateUTxO utxoEnv utxo txs + where + utxoEnv = mkUtxoEnvironment cfg state + utxo = CC.cvsUtxo state + +applyCertificate :: MonadError D.Sched.Error m + => Gen.Config + -> [Delegation.ACertificate ByteString] + -> CC.ChainValidationState -> m CC.ChainValidationState +applyCertificate cfg certs state = + (`setDelegationState` state) <$> + D.Iface.updateDelegation dlgEnv dlgState certs + where + dlgEnv = mkDelegationEnvironment cfg state + dlgState = CC.cvsDelegationState state + +applyUpdateProposal :: MonadError U.Iface.Error m + => Gen.Config + -> Update.AProposal ByteString + -> CC.ChainValidationState -> m CC.ChainValidationState +applyUpdateProposal cfg proposal state = + (`setUpdateState` state) <$> + U.Iface.registerProposal updateEnv updateState proposal + where + updateEnv = mkUpdateEnvironment cfg state + updateState = CC.cvsUpdateState state + +applyUpdateVote :: MonadError U.Iface.Error m + => Gen.Config + -> Update.AVote ByteString + -> CC.ChainValidationState -> m CC.ChainValidationState +applyUpdateVote cfg vote state = + (`setUpdateState` state) <$> + U.Iface.registerVote updateEnv updateState vote + where + updateEnv = mkUpdateEnvironment cfg state + updateState = CC.cvsUpdateState state + +{------------------------------------------------------------------------------- + Apply any kind of transactions +-------------------------------------------------------------------------------} + +-- | Errors that arise from applying an arbitrary mempool payload +-- +-- Although @cardano-legder@ defines 'MempoolPayload', it does not define a +-- corresponding error type. We could 'ChainValidationError', but it's too +-- large, which is problematic because we actually sent encoded versions of +-- these errors across the wire. +data ApplyMempoolPayloadErr = + MempoolTxErr Utxo.UTxOValidationError + | MempoolDlgErr D.Sched.Error + | MempoolUpdateProposalErr U.Iface.Error + | MempoolUpdateVoteErr U.Iface.Error + deriving (Eq, Show) + +instance ToCBOR ApplyMempoolPayloadErr where + toCBOR (MempoolTxErr err) = + CBOR.encodeListLen 2 <> toCBOR (0 :: Word8) <> toCBOR err + toCBOR (MempoolDlgErr err) = + CBOR.encodeListLen 2 <> toCBOR (1 :: Word8) <> toCBOR err + toCBOR (MempoolUpdateProposalErr err) = + CBOR.encodeListLen 2 <> toCBOR (2 :: Word8) <> toCBOR err + toCBOR (MempoolUpdateVoteErr err) = + CBOR.encodeListLen 2 <> toCBOR (3 :: Word8) <> toCBOR err + +instance FromCBOR ApplyMempoolPayloadErr where + fromCBOR = do + enforceSize "ApplyMempoolPayloadErr" 2 + CBOR.decodeWord8 >>= \case + 0 -> MempoolTxErr <$> fromCBOR + 1 -> MempoolDlgErr <$> fromCBOR + 2 -> MempoolUpdateProposalErr <$> fromCBOR + 3 -> MempoolUpdateVoteErr <$> fromCBOR + tag -> cborError $ DecoderErrorUnknownTag "ApplyMempoolPayloadErr" tag + +applyMempoolPayload :: MonadError ApplyMempoolPayloadErr m + => CC.ValidationMode + -> Gen.Config + -> CC.AMempoolPayload ByteString + -> CC.ChainValidationState -> m CC.ChainValidationState +applyMempoolPayload validationMode cfg payload = + case payload of + CC.MempoolTx tx -> + (`wrapError` MempoolTxErr) . + applyTxAux validationMode cfg [tx] + CC.MempoolDlg cert -> + (`wrapError` MempoolDlgErr) . + applyCertificate cfg [cert] + CC.MempoolUpdateProposal proposal -> + (`wrapError` MempoolUpdateProposalErr) . + applyUpdateProposal cfg proposal + CC.MempoolUpdateVote vote -> + (`wrapError` MempoolUpdateVoteErr) . + applyUpdateVote cfg vote + +-- | The encoding of the mempool payload (without a 'AMempoolPayload' envelope) +mempoolPayloadRecoverBytes :: CC.AMempoolPayload ByteString -> ByteString +mempoolPayloadRecoverBytes = go + where + go :: CC.AMempoolPayload ByteString -> ByteString + go (CC.MempoolTx payload) = recoverBytes payload + go (CC.MempoolDlg payload) = recoverBytes payload + go (CC.MempoolUpdateProposal payload) = recoverBytes payload + go (CC.MempoolUpdateVote payload) = recoverBytes payload + +-- | Re-encode the mempool payload (without any envelope) +mempoolPayloadReencode :: CC.AMempoolPayload a -> ByteString +mempoolPayloadReencode = go + where + go (CC.MempoolTx payload) = reencode payload + go (CC.MempoolDlg payload) = reencode payload + go (CC.MempoolUpdateProposal payload) = reencode payload + go (CC.MempoolUpdateVote payload) = reencode payload + + reencode :: (Functor f, ToCBOR (f ())) => f a -> ByteString + reencode = CBOR.toStrictByteString . toCBOR . void + +{------------------------------------------------------------------------------- + Annotations +-------------------------------------------------------------------------------} + +reAnnotateMagicId :: ProtocolMagicId -> Annotated ProtocolMagicId ByteString +reAnnotateMagicId pmi = reAnnotate $ Annotated pmi () + +reAnnotateMagic :: ProtocolMagic -> AProtocolMagic ByteString +reAnnotateMagic (AProtocolMagic a b) = AProtocolMagic (reAnnotate a) b + +reAnnotateBlock :: CC.EpochSlots -> CC.ABlock () -> CC.ABlock ByteString +reAnnotateBlock epochSlots = + reAnnotateUsing + (CC.toCBORBlock epochSlots) + (CC.fromCBORABlock epochSlots) + +reAnnotateBoundary :: ProtocolMagicId + -> CC.ABoundaryBlock () + -> CC.ABoundaryBlock ByteString +reAnnotateBoundary pm = + reAnnotateUsing + (CC.toCBORABoundaryBlock pm) + CC.fromCBORABoundaryBlock + +-- | Generalization of 'reAnnotate' +reAnnotateUsing :: forall f a. Functor f + => (f a -> Encoding) + -> (forall s. Decoder s (f ByteSpan)) + -> f a -> f ByteString +reAnnotateUsing encoder decoder = + (\bs -> splice bs $ CBOR.deserialiseFromBytes decoder bs) + . CBOR.toLazyByteString + . encoder + where + splice :: Show err + => Lazy.ByteString + -> Either err (Lazy.ByteString, f ByteSpan) + -> f ByteString + splice bs (Right (left, fSpan)) + | Lazy.null left = (Lazy.toStrict . slice bs) <$> fSpan + | otherwise = roundtripFailure "leftover bytes" + splice _ (Left err) = roundtripFailure $ show err + + roundtripFailure :: forall x. String -> x + roundtripFailure err = error $ intercalate ": " $ [ + "annotateBoundary" + , "serialization roundtrip failure" + , show err + ] + +{------------------------------------------------------------------------------- + Header of a regular block or EBB + + The ledger layer defines 'ABlockOrBoundary', but no equivalent for headers. +-------------------------------------------------------------------------------} + +data ABlockOrBoundaryHdr a = + ABOBBlockHdr !(CC.AHeader a) + | ABOBBoundaryHdr !(CC.ABoundaryHeader a) + deriving (Eq, Show, Functor, Generic, NoUnexpectedThunks) + +fromCBORABlockOrBoundaryHdr :: CC.EpochSlots + -> Decoder s (ABlockOrBoundaryHdr ByteSpan) +fromCBORABlockOrBoundaryHdr epochSlots = do + enforceSize "ABlockOrBoundaryHdr" 2 + fromCBOR @Word >>= \case + 0 -> ABOBBoundaryHdr <$> CC.fromCBORABoundaryHeader + 1 -> ABOBBlockHdr <$> CC.fromCBORAHeader epochSlots + t -> error $ "Unknown tag in encoded HeaderOrBoundary" <> show t + +-- | The analogue of 'Data.Either.either' +aBlockOrBoundaryHdr :: (CC.AHeader a -> b) + -> (CC.ABoundaryHeader a -> b) + -> ABlockOrBoundaryHdr a -> b +aBlockOrBoundaryHdr f _ (ABOBBlockHdr hdr) = f hdr +aBlockOrBoundaryHdr _ g (ABOBBoundaryHdr hdr) = g hdr + +abobHdrFromBlock :: CC.ABlockOrBoundary a -> ABlockOrBoundaryHdr a +abobHdrFromBlock (CC.ABOBBlock blk) = ABOBBlockHdr $ CC.blockHeader blk +abobHdrFromBlock (CC.ABOBBoundary blk) = ABOBBoundaryHdr $ CC.boundaryHeader blk + +-- | Slot number of the header +-- +-- NOTE: Epoch slot number calculation must match the one in 'applyBoundary'. +abobHdrSlotNo :: CC.EpochSlots -> ABlockOrBoundaryHdr a -> CC.SlotNumber +abobHdrSlotNo epochSlots = + aBlockOrBoundaryHdr + CC.headerSlot + (boundaryBlockSlot epochSlots . CC.boundaryEpoch) + +abobHdrChainDifficulty :: ABlockOrBoundaryHdr a -> CC.ChainDifficulty +abobHdrChainDifficulty = + aBlockOrBoundaryHdr + CC.headerDifficulty + CC.boundaryDifficulty + +abobHdrHash :: ABlockOrBoundaryHdr ByteString -> CC.HeaderHash +abobHdrHash (ABOBBoundaryHdr hdr) = CC.boundaryHeaderHashAnnotated hdr +abobHdrHash (ABOBBlockHdr hdr) = CC.headerHashAnnotated hdr + +abobHdrPrevHash :: ABlockOrBoundaryHdr a -> Maybe CC.HeaderHash +abobHdrPrevHash = + aBlockOrBoundaryHdr + (Just . CC.headerPrevHash) + (either (const Nothing) Just . CC.boundaryPrevHash) + +-- | Check if a block matches its header +-- +-- For EBBs, we're currently being more permissive here and not performing any +-- header-body validation but only checking whether an EBB header and EBB block +-- were provided. This seems to be fine as it won't cause any loss of consensus +-- with the old `cardano-sl` nodes. +abobMatchesBody :: ABlockOrBoundaryHdr ByteString + -> CC.ABlockOrBoundary ByteString + -> Bool +abobMatchesBody hdr blk = + case (hdr, blk) of + (ABOBBlockHdr hdr', CC.ABOBBlock blk') -> matchesBody hdr' blk' + (ABOBBoundaryHdr _, CC.ABOBBoundary _) -> True + (ABOBBlockHdr _, CC.ABOBBoundary _) -> False + (ABOBBoundaryHdr _, CC.ABOBBlock _) -> False + where + matchesBody :: CC.AHeader ByteString -> CC.ABlock ByteString -> Bool + matchesBody hdr' blk' = isRight $ + CC.validateHeaderMatchesBody hdr' (CC.blockBody blk') diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Block.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Block.hs new file mode 100644 index 00000000000..c075f3464ce --- /dev/null +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Block.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Ouroboros.Consensus.Ledger.Byron.Block ( + -- * Hash + ByronHash(..) + , mkByronHash + -- * Block + , ByronBlock(..) + , mkByronBlock + , annotateByronBlock + -- * Header + , Header(..) + , mkByronHeader + , byronBlockMatchesHeader + -- * Serialisation + , encodeByronBlock + , decodeByronBlock + , encodeByronHeader + , decodeByronHeader + , encodeByronHeaderHash + , decodeByronHeaderHash + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as Lazy +import Data.FingerTree.Strict (Measured (..)) +import Data.Proxy +import Data.Typeable +import GHC.Generics (Generic) + +import Codec.CBOR.Decoding (Decoder) +import Codec.CBOR.Encoding (Encoding) +import qualified Codec.CBOR.Encoding as CBOR + +import Cardano.Binary +import Cardano.Prelude (NoUnexpectedThunks (..)) + +import qualified Cardano.Chain.Block as CC +import qualified Cardano.Chain.Slotting as CC + +import Ouroboros.Network.Block + +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Ledger.Byron.Aux +import Ouroboros.Consensus.Ledger.Byron.Conversions +import Ouroboros.Consensus.Ledger.Byron.Orphans () +import Ouroboros.Consensus.Util.Condense + +{------------------------------------------------------------------------------- + Header hash +-------------------------------------------------------------------------------} + +newtype ByronHash = ByronHash { unByronHash :: CC.HeaderHash } + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (ToCBOR, FromCBOR, Condense) + deriving anyclass NoUnexpectedThunks + +mkByronHash :: ABlockOrBoundaryHdr ByteString -> ByronHash +mkByronHash = ByronHash . abobHdrHash + +{------------------------------------------------------------------------------- + Block +-------------------------------------------------------------------------------} + +-- | Byron block +-- +-- We cache two bits of information: +-- +-- * We cache the slot number as this is not readily available for EBBs. +-- Having it cached allows us to e.g. give a 'HasHeader' instance. +-- * We cache the hash as this is expensive to compute and we need it often. +data ByronBlock = ByronBlock { + byronBlockRaw :: !(CC.ABlockOrBoundary ByteString) + , byronBlockSlotNo :: !SlotNo + , byronBlockHash :: !ByronHash + } + deriving (Eq, Show) + +instance Condense ByronBlock where + condense = condense . byronBlockRaw + +mkByronBlock :: CC.EpochSlots -> CC.ABlockOrBoundary ByteString -> ByronBlock +mkByronBlock epochSlots blk = ByronBlock { + byronBlockRaw = blk + , byronBlockSlotNo = fromByronSlotNo $ abobHdrSlotNo epochSlots hdr + , byronBlockHash = mkByronHash hdr + } + where + hdr = abobHdrFromBlock blk + +-- | Construct Byron block from unannotated 'CC.Block' +-- +-- This should be used only when forging blocks (not when receiving blocks +-- over the wire). +annotateByronBlock :: CC.EpochSlots -> CC.Block -> ByronBlock +annotateByronBlock es = mkByronBlock es . CC.ABOBBlock . reAnnotateBlock es + +{------------------------------------------------------------------------------- + Header +-------------------------------------------------------------------------------} + +instance GetHeader ByronBlock where + -- | Byron header + -- + -- See 'ByronBlock' for comments on why we cache certain values. + data Header ByronBlock = ByronHeader { + byronHeaderRaw :: !(ABlockOrBoundaryHdr ByteString) + , byronHeaderSlotNo :: !SlotNo + , byronHeaderHash :: !ByronHash + } + deriving (Eq, Show, Generic) + + getHeader ByronBlock{..} = ByronHeader{ + byronHeaderRaw = abobHdrFromBlock byronBlockRaw + , byronHeaderSlotNo = byronBlockSlotNo + , byronHeaderHash = byronBlockHash + } + +instance Condense (Header ByronBlock) where + condense = aBlockOrBoundaryHdr condense condense . byronHeaderRaw + +instance NoUnexpectedThunks (Header ByronBlock) where + showTypeOf _ = show $ typeRep (Proxy @(Header ByronBlock)) + +mkByronHeader :: CC.EpochSlots + -> ABlockOrBoundaryHdr ByteString + -> Header ByronBlock +mkByronHeader epochSlots hdr = ByronHeader { + byronHeaderRaw = hdr + , byronHeaderSlotNo = fromByronSlotNo $ abobHdrSlotNo epochSlots hdr + , byronHeaderHash = mkByronHash hdr + } + +-- | Check if a block matches its header +byronBlockMatchesHeader :: Header ByronBlock -> ByronBlock -> Bool +byronBlockMatchesHeader hdr blk = + abobMatchesBody (byronHeaderRaw hdr) (byronBlockRaw blk) + +{------------------------------------------------------------------------------- + HasHeader instances + + This doesn't do much more than pass to the instance for headers. +-------------------------------------------------------------------------------} + +type instance HeaderHash ByronBlock = ByronHash +instance StandardHash ByronBlock + +instance HasHeader ByronBlock where + blockHash = blockHash . getHeader + blockPrevHash = castHash . blockPrevHash . getHeader + blockSlot = blockSlot . getHeader + blockNo = blockNo . getHeader + blockInvariant = const True + +instance HasHeader (Header ByronBlock) where + blockHash = byronHeaderHash + blockSlot = byronHeaderSlotNo + blockPrevHash = fromByronPrevHash' . abobHdrPrevHash . byronHeaderRaw + blockNo = fromByronBlockNo . abobHdrChainDifficulty . byronHeaderRaw + blockInvariant = const True + +instance Measured BlockMeasure ByronBlock where + measure = blockMeasure + +fromByronPrevHash' :: Maybe CC.HeaderHash -> ChainHash (Header ByronBlock) +fromByronPrevHash' = fromByronPrevHash ByronHash + +{------------------------------------------------------------------------------- + Serialisation +-------------------------------------------------------------------------------} + +encodeByronHeaderHash :: HeaderHash ByronBlock -> Encoding +encodeByronHeaderHash = toCBOR + +decodeByronHeaderHash :: Decoder s (HeaderHash ByronBlock) +decodeByronHeaderHash = fromCBOR + +-- | Encode a block +-- +-- Should be backwards compatible with legacy (cardano-sl) nodes. +-- +-- Implementation note: the decoder uses 'CC.fromCBORABlockOrBoundary', which +-- has inverse 'CC.toCBORABlockOrBoundary'. This encoder is intended to be +-- binary compatible with 'CC.toCBORABlockOrBoundary', but does not use it and +-- instead takes advantage of the annotations (using 'encodePreEncoded'). +encodeByronBlock :: ByronBlock -> Encoding +encodeByronBlock blk = mconcat [ + CBOR.encodeListLen 2 + , case byronBlockRaw blk of + CC.ABOBBoundary b -> mconcat [ + CBOR.encodeWord 0 + , CBOR.encodePreEncoded $ CC.boundaryAnnotation b + ] + CC.ABOBBlock b -> mconcat [ + CBOR.encodeWord 1 + , CBOR.encodePreEncoded $ CC.blockAnnotation b + ] + ] + +-- | Inverse of 'encodeByronBlock' +decodeByronBlock :: CC.EpochSlots -> Decoder s (Lazy.ByteString -> ByronBlock) +decodeByronBlock epochSlots = + fillInByteString <$> CC.fromCBORABlockOrBoundary epochSlots + where + fillInByteString :: CC.ABlockOrBoundary ByteSpan + -> Lazy.ByteString + -> ByronBlock + fillInByteString it theBytes = mkByronBlock epochSlots $ + Lazy.toStrict . slice theBytes <$> it + +-- | Encode a header +-- +-- Should be backwards compatible with legacy (cardano-sl) nodes. +-- +-- This function should be inverse to 'decodeByronHeader' +-- (which uses 'fromCBORABlockOrBoundaryHdr'). +encodeByronHeader :: Header ByronBlock -> Encoding +encodeByronHeader hdr = mconcat [ + CBOR.encodeListLen 2 + , case byronHeaderRaw hdr of + ABOBBoundaryHdr h -> mconcat [ + CBOR.encodeWord 0 + , CBOR.encodePreEncoded $ CC.boundaryHeaderAnnotation h + ] + ABOBBlockHdr h -> mconcat [ + CBOR.encodeWord 1 + , CBOR.encodePreEncoded $ CC.headerAnnotation h + ] + ] + +-- | Inverse of 'encodeByronHeader' +decodeByronHeader :: CC.EpochSlots + -> Decoder s (Lazy.ByteString -> Header ByronBlock) +decodeByronHeader epochSlots = + fillInByteString <$> fromCBORABlockOrBoundaryHdr epochSlots + where + fillInByteString :: ABlockOrBoundaryHdr ByteSpan + -> Lazy.ByteString + -> Header ByronBlock + fillInByteString it theBytes = mkByronHeader epochSlots $ + Lazy.toStrict . slice theBytes <$> it diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/ContainsGenesis.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/ContainsGenesis.hs index 87f56d6918f..9c03419f04b 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/ContainsGenesis.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/ContainsGenesis.hs @@ -12,11 +12,11 @@ import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.PBFT class ConfigContainsGenesis cfg where - genesisConfig :: cfg -> CC.Genesis.Config + getGenesisConfig :: cfg -> CC.Genesis.Config instance ConfigContainsGenesis ByronConfig where - genesisConfig = pbftGenesisConfig + getGenesisConfig = pbftGenesisConfig instance ConfigContainsGenesis cfg => ConfigContainsGenesis (NodeConfig (PBft cfg c)) where - genesisConfig = genesisConfig . pbftExtConfig + getGenesisConfig = getGenesisConfig . pbftExtConfig diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Conversions.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Conversions.hs new file mode 100644 index 00000000000..488f31104ca --- /dev/null +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Conversions.hs @@ -0,0 +1,40 @@ +module Ouroboros.Consensus.Ledger.Byron.Conversions ( + -- * From @cardano-ledger@ to @ouroboros-consensus@ + fromByronPrevHash + , fromByronSlotNo + , fromByronBlockNo + -- From @ouroboros-consensus@ to @cardano-ledger@ + , toByronSlotNo + ) where + +import Data.Coerce + +import qualified Cardano.Chain.Block as CC +import qualified Cardano.Chain.Common as CC +import qualified Cardano.Chain.Slotting as CC + +import Ouroboros.Network.Block + +import Ouroboros.Consensus.Ledger.Byron.Orphans () + +{------------------------------------------------------------------------------- + From @cardano-ledger@ to @ouroboros-consensus@ +-------------------------------------------------------------------------------} + +fromByronPrevHash :: (CC.HeaderHash -> HeaderHash b) + -> Maybe CC.HeaderHash -> ChainHash b +fromByronPrevHash _ Nothing = GenesisHash +fromByronPrevHash f (Just h) = BlockHash (f h) + +fromByronSlotNo :: CC.SlotNumber -> SlotNo +fromByronSlotNo = coerce + +fromByronBlockNo :: CC.ChainDifficulty -> BlockNo +fromByronBlockNo = coerce + +{------------------------------------------------------------------------------- + From @ouroboros-consensus@ to @cardano-ledger@ +-------------------------------------------------------------------------------} + +toByronSlotNo :: SlotNo -> CC.SlotNumber +toByronSlotNo = coerce diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/DelegationHistory.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/DelegationHistory.hs new file mode 100644 index 00000000000..edabd3adc50 --- /dev/null +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/DelegationHistory.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Delegation history +-- +-- Intended for qualified import +module Ouroboros.Consensus.Ledger.Byron.DelegationHistory ( + DelegationHistory + , empty + , toSequence + , snapOld + , find + -- * Serialisation + , encodeDelegationHistory + , decodeDelegationHistory + ) where + +import Codec.CBOR.Decoding (Decoder) +import Codec.CBOR.Encoding (Encoding) +import Codec.Serialise (decode, encode) +import Data.Coerce +import qualified Data.Foldable as Foldable +import Data.Sequence.Strict (StrictSeq ((:<|), (:|>), Empty)) +import qualified Data.Sequence.Strict as Seq + +import Cardano.Prelude (NoUnexpectedThunks) + +import qualified Cardano.Chain.Common as CC +import qualified Cardano.Chain.Delegation as Delegation + +import Ouroboros.Network.Block (SlotNo (..), genesisSlotNo) +import Ouroboros.Network.Point (WithOrigin (..), fromWithOrigin) + +import Ouroboros.Consensus.Ledger.Byron.PBFT +import Ouroboros.Consensus.Protocol.PBFT +import Ouroboros.Consensus.Util.SlotBounded (Bounds (..), + SlotBounded (..)) +import qualified Ouroboros.Consensus.Util.SlotBounded as SB + +{------------------------------------------------------------------------------- + Delegation history +-------------------------------------------------------------------------------} + +-- | Delegation history +-- +-- Motivation: the ledger state gives us both the current delegation state +-- ('getDelegationMap') as well any planned future changes to the delegation +-- state ('getScheduledDelegations'). It does not however give us information +-- about past delegation states. This is where the 'DelegationHistory' comes in. +-- +-- Each time that the delegation state is updated (that is, when applying a +-- block that changes the delegation state), we take a snapshot of the /old/ +-- delegation state (the delegation state as it was before the block was +-- applied). +-- +-- We store the delegation state state along with its slot bounds: +-- +-- * The slot number of the block that changed the delegation state serves as an +-- /exclusive/ upper bound. +-- * The (exclusive) upper bound of the /previous/ historical delegation state +-- serves as an /inclusive/ lower bound (since this is the slot at which this +-- delegation state became active). +-- +-- We never need to go back in history for more than @2k@ slots, allowing us +-- to drop delegation states from history as time passes, keeping the history +-- bounded in size. We will however always keep at least /one/ value, so that +-- we correctly compute the lower bound when we take a snapshot. (Alternatively, +-- we could set "good enough" lower bounds based on the @2k@ limit, but this +-- design is easier to understand and verify). +-- +-- The delegation history will only be empty if delegation has never changed; +-- in this case, the first snapshot we add must be the genesis delegation and +-- so its lower bound will be 'genesisSlotNo'. +newtype DelegationHistory = DelegationHistory { + -- | Sequence of historical snapshots (see above) + -- + -- More recent snapshots are stored at the end of the sequence. + -- + -- Invariant: the (exclusive) upper bound of each snapshot must equal the + -- (inclusive) lower bound of the next. + toSequence :: StrictSeq Snapshot + } + deriving (Show, Eq, NoUnexpectedThunks) + +-- | Historical snapshot of the delegation state +-- +-- See 'DelegationHistory' for details +type Snapshot = SlotBounded IX Delegation.Map + +-- | Empty (genesis) delegation history +-- +-- The delegation history should only be empty if it has never changed. +empty :: DelegationHistory +empty = DelegationHistory Seq.empty + +-- | Internal auxiliary +withDelegationHistory :: (StrictSeq Snapshot -> StrictSeq Snapshot) + -> DelegationHistory -> DelegationHistory +withDelegationHistory = coerce + +-- | Take a snapshot of the delegation state +snapOld :: CC.BlockCount -- ^ Maximum rollback (@k@) + -> SlotNo -- ^ Slot number of the block that changed delegation + -> Delegation.Map -- ^ Delegation state /before/ it changed + -> DelegationHistory -> DelegationHistory +snapOld k now old = trim k now . withDelegationHistory append + where + append :: StrictSeq Snapshot -> StrictSeq Snapshot + append ss = ss :|> SB.bounded (lowerBound ss) now old + + lowerBound :: StrictSeq Snapshot -> SlotNo + lowerBound Empty = genesisSlotNo + lowerBound (_ :|> s) = sbUpper s + +-- | Drop snapshots guaranteed not to be needed anymore +-- +-- Implementation note: the snapshots look something like +-- +-- > [......)[...............)[....) +-- > ^ ^ +-- > earliest now +-- +-- We process them from old to now. Any old snapshots that do not contain +-- @earliest@ are removed, and stop as soon we find the first snapshot that +-- /does/ contain@earliest@. +-- +-- We always leave at least one snapshot in the list (see 'DelegationHistory'). +trim :: CC.BlockCount -- ^ Maximum rollback (@k@) + -> SlotNo -- ^ Current slot + -> DelegationHistory -> DelegationHistory +trim k now = withDelegationHistory go + where + go :: StrictSeq Snapshot -> StrictSeq Snapshot + go Empty = Empty + go (s :<| Empty) = s :<| Empty + go (s :<| ss) = if s `SB.contains` earliest + then s :<| ss + else go ss + + -- Earliest slot we might roll back to + earliest :: SlotNo + earliest = now - 2 * coerce k + +find :: WithOrigin SlotNo -> DelegationHistory -> Maybe Snapshot +find slot = Foldable.find (`SB.contains` slot') . toSequence + where + slot' :: SlotNo + slot' = fromWithOrigin genesisSlotNo slot + +{------------------------------------------------------------------------------- + Serialisation + + We translate to @PBftLedgerView@ so that we can piggy-back on its @Serialise@ + instance. +-------------------------------------------------------------------------------} + +toLedgerViews :: DelegationHistory + -> [SlotBounded IX (PBftLedgerView PBftCardanoCrypto)] +toLedgerViews = + map (fmap toPBftLedgerView) + . Foldable.toList + . toSequence + +fromLedgerViews :: [SlotBounded IX (PBftLedgerView PBftCardanoCrypto)] + -> DelegationHistory +fromLedgerViews = + DelegationHistory + . Seq.fromList + . map (fmap fromPBftLedgerView) + +encodeDelegationHistory :: DelegationHistory -> Encoding +encodeDelegationHistory = encode . toLedgerViews + +decodeDelegationHistory :: Decoder s DelegationHistory +decodeDelegationHistory = fromLedgerViews <$> decode diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Forge.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Forge.hs index 1cdf9d5cfbf..6a4f669ecef 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Forge.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Forge.hs @@ -29,13 +29,15 @@ import Cardano.Crypto.DSIGN import Ouroboros.Network.Block import Ouroboros.Consensus.Crypto.DSIGN.Cardano -import Ouroboros.Consensus.Ledger.Byron +import Ouroboros.Consensus.Ledger.Byron.Aux +import Ouroboros.Consensus.Ledger.Byron.Block +import Ouroboros.Consensus.Ledger.Byron.Config import Ouroboros.Consensus.Ledger.Byron.ContainsGenesis +import Ouroboros.Consensus.Ledger.Byron.Mempool +import Ouroboros.Consensus.Ledger.Byron.PBFT import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.PBFT -import Ouroboros.Consensus.Ledger.Byron.Config - forgeByronBlock :: forall m. ( HasNodeState_ () m -- @()@ is the @NodeState@ of PBFT @@ -59,10 +61,10 @@ forgeGenesisEBB forgeGenesisEBB cfg curSlot = mkByronBlock pbftEpochSlots . CC.Block.ABOBBoundary - . annotateBoundary protocolMagicId + . reAnnotateBoundary protocolMagicId $ boundaryBlock where - protocolMagicId = CC.Genesis.configProtocolMagicId (genesisConfig cfg) + protocolMagicId = CC.Genesis.configProtocolMagicId (getGenesisConfig cfg) ByronConfig { pbftGenesisHash , pbftEpochSlots } = pbftExtConfig cfg @@ -70,8 +72,7 @@ forgeGenesisEBB cfg curSlot = boundaryBlock :: CC.Block.ABoundaryBlock () boundaryBlock = CC.Block.ABoundaryBlock { - CC.Block.boundaryBlockLength = 0 -- Since this is a demo and we - -- ignore the length, set this to 0 + CC.Block.boundaryBlockLength = 0 -- Used only in testing anyway , CC.Block.boundaryHeader , CC.Block.boundaryBody = CC.Block.ABoundaryBody () , CC.Block.boundaryAnnotation = () diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Ledger.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Ledger.hs new file mode 100644 index 00000000000..2073c8c9ce7 --- /dev/null +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Ledger.hs @@ -0,0 +1,316 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Instances requires for consensus/ledger integration +module Ouroboros.Consensus.Ledger.Byron.Ledger ( + -- * Ledger integration + LedgerConfig(..) + , LedgerState(..) + -- * Serialisation + , encodeByronLedgerState + , decodeByronLedgerState + -- * Auxiliary + , validationErrorImpossible + ) where + +import Codec.CBOR.Decoding (Decoder) +import qualified Codec.CBOR.Decoding as CBOR +import Codec.CBOR.Encoding (Encoding) +import qualified Codec.CBOR.Encoding as CBOR +import Codec.Serialise (decode, encode) +import Control.Monad.Except +import Data.ByteString (ByteString) +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq.Lazy +import qualified Data.Sequence.Strict as Seq +import GHC.Generics (Generic) + +import Cardano.Prelude (NoUnexpectedThunks) + +import qualified Cardano.Chain.Block as CC +import qualified Cardano.Chain.Delegation as Delegation +import qualified Cardano.Chain.Delegation.Validation.Scheduling as D.Sched +import qualified Cardano.Chain.Genesis as Gen +import qualified Cardano.Chain.ValidationMode as CC + +import Ouroboros.Network.Block (Point (..), SlotNo (..), + genesisSlotNo) +import Ouroboros.Network.Point (WithOrigin (..)) +import qualified Ouroboros.Network.Point as Point + +import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Ledger.Byron.Aux +import Ouroboros.Consensus.Ledger.Byron.Block +import Ouroboros.Consensus.Ledger.Byron.Config +import Ouroboros.Consensus.Ledger.Byron.ContainsGenesis +import Ouroboros.Consensus.Ledger.Byron.Conversions +import Ouroboros.Consensus.Ledger.Byron.DelegationHistory + (DelegationHistory) +import qualified Ouroboros.Consensus.Ledger.Byron.DelegationHistory as History +import Ouroboros.Consensus.Ledger.Byron.PBFT +import Ouroboros.Consensus.Protocol.Abstract +import Ouroboros.Consensus.Protocol.PBFT +import qualified Ouroboros.Consensus.Util.SlotBounded as SB + +instance UpdateLedger ByronBlock where + + data LedgerState ByronBlock = ByronLedgerState { + byronLedgerState :: !CC.ChainValidationState + , byronDelegationHistory :: !DelegationHistory + } + deriving (Eq, Show, Generic, NoUnexpectedThunks) + + type LedgerError ByronBlock = CC.ChainValidationError + + newtype LedgerConfig ByronBlock = ByronLedgerConfig { + unByronLedgerConfig :: Gen.Config + } + + ledgerConfigView PBftNodeConfig{..} = ByronLedgerConfig $ + pbftGenesisConfig pbftExtConfig + + applyChainTick cfg slotNo ByronLedgerState{..} = return ByronLedgerState { + byronDelegationHistory = byronDelegationHistory + , byronLedgerState = applyEpochTransition + (unByronLedgerConfig cfg) + (toByronSlotNo slotNo) + byronLedgerState + } + + applyLedgerBlock = applyByronBlock validationMode + where + validationMode = CC.fromBlockValidationMode CC.BlockValidation + + reapplyLedgerBlock cfg blk st = + validationErrorImpossible $ + applyByronBlock validationMode cfg blk st + where + validationMode = CC.fromBlockValidationMode CC.NoBlockValidation + + ledgerTipPoint (ByronLedgerState state _) = + case CC.cvsPreviousHash state of + -- In this case there are no blocks in the ledger state. The genesis + -- block does not occupy a slot, so its point is Origin. + Left _genHash -> Point Point.origin + Right hdrHash -> Point (Point.block slot (ByronHash hdrHash)) + where + slot = fromByronSlotNo (CC.cvsLastSlot state) + +instance ConfigContainsGenesis (LedgerConfig ByronBlock) where + getGenesisConfig = unByronLedgerConfig + +instance ProtocolLedgerView ByronBlock where + protocolLedgerView _cfg = + toPBftLedgerView + . getDelegationMap + . byronLedgerState + + -- Delegation state for a particular point in time + -- + -- The situation looks something like this: + -- + -- > (Label for reference) 0 1 2 3 4 + -- > ------------------------------------------------------------------------- + -- > Delegation changes v v v v v + -- > Snapshots [......)[............)[.....) NOW + -- > Requested slot A B C D + -- + -- where NOW refers to the slot number of the last block we applied, and + -- the requested slot must be within a @[-2k .. +2k)@ window around NOW. + -- + -- Note that there can be no delegation changes between (2) and (NOW): if + -- there were, we'd have another snapshot. Four possibilities: + -- + -- A. We have a historical snapshot of the delegation state that contains the + -- requested slot. If so, we just return that. + -- B. The slot is in the past, but we have no snapshot. In this case, it must + -- be that the current ledger state is valid, between points (2) and (3). + -- C. The slot is in the future, but before the first scheduled change to the + -- delegation state. Again, current ledger state is valid, also between + -- points (2) and (3). + -- D. The slot is in the future, but after the first scheduled update. We must + -- apply that scheduled update; the resulting delegation state will be + -- valid from the point of that first schedulded update (3) until the + -- next (4). + -- + -- We can collapse cases (B, C, D) into a single one as follows: split the + -- scheduled delegations into the ones that should have been applied at the + -- requested slot, and those that are still in the future. For the example + -- above this amounts to + -- + -- B. ([], (3, 4)] + -- C. ([], (3, 4)] + -- D. ([3], [4]) + -- + -- Then take the delegation state from in current ledger state, and apply the + -- updates that should be applied. The resulting delegation state must be + -- given the following validity bounds: + -- + -- * The lower bound will be the slot number of the last update that was + -- applied, or the upper bound of the last historical snapshot if no + -- updates needed to be applied. If there are no historical snapshots, + -- then the lower bound is genesis (the history is only empty if the + -- delegation state never changed). + -- * The upper bound will be the slot number of the first update that was + -- not yet applied; if no such update is known, it will be set to the + -- the maximum upper bound @(NOW + 2k)@. + -- + -- TODO: verify that the sdSlot of ScheduledDelegation is the slot at which + -- it becomes active (i.e., that delegation should be applied /in/ that slot) + -- i.e., that delegate is allowed to issue a block in that very same slot. + anachronisticProtocolLedgerView cfg (ByronLedgerState ls ss) slot = + case History.find slot ss of + Just sb -> Right (toPBftLedgerView <$> sb) -- Case (A) + Nothing -- Case (B), (C) or (D) + | slot < At maxLo -> Left TooFarBehind -- lower bound is inclusive + | slot >= At maxHi -> Left TooFarAhead -- upper bound is exclusive + | otherwise -> Right $ toPBftLedgerView <$> + + let toApply :: Seq D.Sched.ScheduledDelegation + future :: Seq D.Sched.ScheduledDelegation + (toApply, future) = splitScheduledDelegations slot $ + getScheduledDelegations ls + + lo, hi :: SlotNo + lo = case (toApply, History.toSequence ss) of + (_ Seq.Lazy.:|> upd, _) -> + -- Case (D) + fromByronSlotNo (D.Sched.sdSlot upd) + (Seq.Lazy.Empty, _ Seq.:|> prev) -> + -- Case (B) or (C) + SB.sbUpper prev + (Seq.Lazy.Empty, Seq.Empty) -> + -- History never changed + genesisSlotNo + hi = case future of + Seq.Lazy.Empty -> + -- No known future delegations + -- + -- The spec mandates that new delegation certificates + -- cannot kick in within 2k slots, so this is a safe + -- upper bound. + maxHi + upd Seq.Lazy.:<| _ -> + fromByronSlotNo (D.Sched.sdSlot upd) + + in SB.bounded lo hi $ applyScheduledDelegations toApply dsNow + where + SecurityParam k = pbftSecurityParam . pbftParams $ cfg + + dsNow :: Delegation.Map + dsNow = getDelegationMap ls + + now, maxHi, maxLo :: SlotNo + now = fromByronSlotNo $ CC.cvsLastSlot ls + maxLo = SlotNo $ if (2 * k) > unSlotNo now + then 0 + else unSlotNo now - (2 * k) + maxHi = SlotNo $ unSlotNo now + (2 * k) + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +-- | Mark computation as validation error free +-- +-- Given a 'BlockValidationMode' of 'NoBlockValidation', a call to +-- 'applyByronBlock' shouldn't fail since the ledger layer won't be performing +-- any block validation checks. However, because 'applyByronBlock' can fail in +-- the event it is given a 'BlockValidationMode' of 'BlockValidation', it still +-- /looks/ like it can fail (since its type doesn't change based on the +-- 'ValidationMode') and we must still treat it as such. +validationErrorImpossible :: forall err a. Except err a -> a +validationErrorImpossible = cantBeError . runExcept + where + cantBeError :: Either err a -> a + cantBeError (Left _) = error "validationErrorImpossible: unexpected error" + cantBeError (Right a) = a + +-- | Split scheduled delegations into past and future +splitScheduledDelegations :: WithOrigin SlotNo + -> Seq D.Sched.ScheduledDelegation + -> ( Seq D.Sched.ScheduledDelegation + , Seq D.Sched.ScheduledDelegation + ) +splitScheduledDelegations slot = + -- spanl finds the longest prefix of elements that satisfy the predicate + Seq.Lazy.spanl shouldApply + where + shouldApply :: D.Sched.ScheduledDelegation -> Bool + shouldApply sd = At (fromByronSlotNo (D.Sched.sdSlot sd)) <= slot + +{------------------------------------------------------------------------------- + Applying a block + + Most of the work here is done by the ledger layer. We just need to pass + the right arguments, and maintain the snapshots. +-------------------------------------------------------------------------------} + +applyByronBlock :: CC.ValidationMode + -> LedgerConfig ByronBlock + -> ByronBlock + -> LedgerState ByronBlock + -> Except (LedgerError ByronBlock) (LedgerState ByronBlock) +applyByronBlock validationMode + (ByronLedgerConfig cfg) + (ByronBlock blk _ (ByronHash blkHash)) = + case blk of + CC.ABOBBlock blk' -> applyABlock validationMode cfg blk' blkHash + CC.ABOBBoundary blk' -> applyABoundaryBlock cfg blk' + +applyABlock :: CC.ValidationMode + -> Gen.Config + -> CC.ABlock ByteString + -> CC.HeaderHash + -> LedgerState (ByronBlock) + -> Except (LedgerError ByronBlock) (LedgerState ByronBlock) +applyABlock validationMode cfg blk blkHash ByronLedgerState{..} = do + state' <- validateBlock cfg validationMode blk blkHash byronLedgerState + -- If the delegation state changed, take a snapshot of the old state + let history' + | CC.cvsDelegationState state' + == CC.cvsDelegationState byronLedgerState + = byronDelegationHistory + | otherwise = History.snapOld + (Gen.configK cfg) + (fromByronSlotNo $ CC.blockSlot blk) + (getDelegationMap byronLedgerState) -- the old state! + byronDelegationHistory + return $ ByronLedgerState state' history' + +-- | Apply boundary block +-- +-- Since boundary blocks don't modify the delegation state, they also don't +-- modify the delegation history. +applyABoundaryBlock :: Gen.Config + -> CC.ABoundaryBlock ByteString + -> LedgerState ByronBlock + -> Except (LedgerError ByronBlock) (LedgerState ByronBlock) +applyABoundaryBlock cfg blk ByronLedgerState{..} = do + current' <- validateBoundary cfg blk byronLedgerState + return $ ByronLedgerState current' byronDelegationHistory + +{------------------------------------------------------------------------------- + Serialisation +-------------------------------------------------------------------------------} + +encodeByronLedgerState :: LedgerState ByronBlock -> Encoding +encodeByronLedgerState ByronLedgerState{..} = mconcat + [ CBOR.encodeListLen 2 + , encode byronLedgerState + , History.encodeDelegationHistory byronDelegationHistory + ] + +decodeByronLedgerState :: Decoder s (LedgerState ByronBlock) +decodeByronLedgerState = do + CBOR.decodeListLenOf 2 + ByronLedgerState + <$> decode + <*> History.decodeDelegationHistory diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Mempool.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Mempool.hs new file mode 100644 index 00000000000..b2591e6dadd --- /dev/null +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Mempool.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Byron mempool integration +module Ouroboros.Consensus.Ledger.Byron.Mempool ( + -- * Mempool integration + GenTx(..) + , GenTxId(..) + -- * Serialisation + , encodeByronGenTx + , decodeByronGenTx + , encodeByronGenTxId + , decodeByronGenTxId + , encodeByronApplyTxError + , decodeByronApplyTxError + -- * Low-level API (primarily for testing) + , toMempoolPayload + , fromMempoolPayload + ) where + +import Codec.CBOR.Decoding (Decoder) +import qualified Codec.CBOR.Decoding as CBOR +import Codec.CBOR.Encoding (Encoding) +import qualified Codec.CBOR.Encoding as CBOR +import Control.Monad.Except +import Data.ByteString (ByteString) +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as Lazy +import Data.Word +import GHC.Generics (Generic) + +import Cardano.Binary (ByteSpan, DecoderError (..), FromCBOR (..), + ToCBOR (..), enforceSize, fromCBOR, serialize, slice, + toCBOR, unsafeDeserialize) +import Cardano.Crypto (hashDecoded) +import Cardano.Prelude (NoUnexpectedThunks (..), UseIsNormalForm (..), + cborError) + +import qualified Cardano.Chain.Block as CC +import qualified Cardano.Chain.Delegation as Delegation +import qualified Cardano.Chain.MempoolPayload as CC +import qualified Cardano.Chain.Update.Proposal as Update +import qualified Cardano.Chain.Update.Vote as Update +import qualified Cardano.Chain.UTxO as Utxo +import qualified Cardano.Chain.ValidationMode as CC + +import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Ledger.Byron.Aux +import Ouroboros.Consensus.Ledger.Byron.Block +import Ouroboros.Consensus.Ledger.Byron.Ledger +import Ouroboros.Consensus.Ledger.Byron.Orphans () +import Ouroboros.Consensus.Mempool.API +import Ouroboros.Consensus.Util.Condense + +{------------------------------------------------------------------------------- + Transactions +-------------------------------------------------------------------------------} + +instance ApplyTx ByronBlock where + -- | Generalized transactions in Byron + -- + -- This is effectively the same as 'CC.AMempoolPayload' but we cache the + -- transaction ID (a hash). + data GenTx ByronBlock + = ByronTx !Utxo.TxId !(Utxo.ATxAux ByteString) + | ByronDlg !Delegation.CertificateId !(Delegation.ACertificate ByteString) + | ByronUpdateProposal !Update.UpId !(Update.AProposal ByteString) + | ByronUpdateVote !Update.VoteId !(Update.AVote ByteString) + deriving (Eq, Generic) + deriving NoUnexpectedThunks via UseIsNormalForm (GenTx ByronBlock) + + data GenTxId ByronBlock + = ByronTxId !Utxo.TxId + | ByronDlgId !Delegation.CertificateId + | ByronUpdateProposalId !Update.UpId + | ByronUpdateVoteId !Update.VoteId + deriving (Eq, Ord) + + txId (ByronTx i _) = ByronTxId i + txId (ByronDlg i _) = ByronDlgId i + txId (ByronUpdateProposal i _) = ByronUpdateProposalId i + txId (ByronUpdateVote i _) = ByronUpdateVoteId i + + txSize tx = + 1 {- encodeListLen -} + + 1 {- tag -} + + (fromIntegral . Strict.length $ mempoolPayloadRecoverBytes tx') + where + tx' = toMempoolPayload tx + + -- Check that the annotation is the canonical encoding. This is currently + -- enforced by 'decodeByronGenTx', see its docstring for more context. + txInvariant tx = + mempoolPayloadRecoverBytes tx' == mempoolPayloadReencode tx' + where + tx' = toMempoolPayload tx + + type ApplyTxErr ByronBlock = ApplyMempoolPayloadErr + + applyTx = applyByronGenTx validationMode + where + validationMode = CC.ValidationMode CC.BlockValidation Utxo.TxValidation + + reapplyTx = applyByronGenTx validationMode + where + validationMode = CC.ValidationMode CC.NoBlockValidation Utxo.TxValidationNoCrypto + + reapplyTxSameState cfg tx st = + validationErrorImpossible $ + applyByronGenTx validationMode cfg tx st + where + validationMode = CC.ValidationMode CC.NoBlockValidation Utxo.NoTxValidation + +{------------------------------------------------------------------------------- + Conversion to and from 'AMempoolPayload' +-------------------------------------------------------------------------------} + +toMempoolPayload :: GenTx ByronBlock -> CC.AMempoolPayload ByteString +toMempoolPayload = go + where + -- Just extract the payload @p@ + go :: GenTx ByronBlock -> CC.AMempoolPayload ByteString + go (ByronTx _ p) = CC.MempoolTx p + go (ByronDlg _ p) = CC.MempoolDlg p + go (ByronUpdateProposal _ p) = CC.MempoolUpdateProposal p + go (ByronUpdateVote _ p) = CC.MempoolUpdateVote p + +fromMempoolPayload :: CC.AMempoolPayload ByteString -> GenTx ByronBlock +fromMempoolPayload = go + where + -- Bundle the payload @p@ with its ID + go :: CC.AMempoolPayload ByteString -> GenTx ByronBlock + go (CC.MempoolTx p) = ByronTx (idTx p) p + go (CC.MempoolDlg p) = ByronDlg (idDlg p) p + go (CC.MempoolUpdateProposal p) = ByronUpdateProposal (idProp p) p + go (CC.MempoolUpdateVote p) = ByronUpdateVote (idVote p) p + + idTx = hashDecoded . Utxo.aTaTx -- TODO (cardano-ledger#581) + idDlg = Delegation.recoverCertificateId + idProp = Update.recoverUpId + idVote = Update.recoverVoteId + +{------------------------------------------------------------------------------- + Pretty-printing +-------------------------------------------------------------------------------} + +instance Condense (GenTx ByronBlock) where + condense = condense . toMempoolPayload + +instance Condense (GenTxId ByronBlock) where + condense (ByronTxId i) = "txid: " <> condense i + condense (ByronDlgId i) = "dlgid: " <> condense i + condense (ByronUpdateProposalId i) = "updateproposalid: " <> condense i + condense (ByronUpdateVoteId i) = "updatevoteid: " <> condense i + +instance Show (GenTx ByronBlock) where + show = condense + +instance Show (GenTxId ByronBlock) where + show = condense + +{------------------------------------------------------------------------------- + Applying transactions +-------------------------------------------------------------------------------} + +applyByronGenTx :: CC.ValidationMode + -> LedgerConfig ByronBlock + -> GenTx ByronBlock + -> LedgerState ByronBlock + -> Except (ApplyTxErr ByronBlock) (LedgerState ByronBlock) +applyByronGenTx validationMode cfg genTx st = + (\state -> st {byronLedgerState = state}) <$> + applyMempoolPayload + validationMode + (unByronLedgerConfig cfg) + (toMempoolPayload genTx) + (byronLedgerState st) + +{------------------------------------------------------------------------------- + Serialisation +-------------------------------------------------------------------------------} + +encodeByronGenTx :: GenTx ByronBlock -> Encoding +encodeByronGenTx genTx = toCBOR (toMempoolPayload genTx) + +-- | The 'ByteString' annotation will be the canonical encoding. +-- +-- While the new implementation does not care about canonical encodings, the +-- old one does. When a generalised transaction arrives that is not in its +-- canonical encoding (only the 'CC.UTxO.ATxAux' of the 'ByronTx' can be +-- produced by nodes that are not under our control), the old implementation +-- will reject it. Therefore, we need to reject them too. See #905. +-- +-- We use the ledger to check for canonical encodings: the ledger will check +-- whether the signed hash of the transaction (in the case of a +-- 'CC.UTxO.ATxAux', the transaction witness) matches the annotated +-- bytestring. Is therefore __important__ that the annotated bytestring be the +-- /canonical/ encoding, not the /original, possibly non-canonical/ encoding. +decodeByronGenTx :: Decoder s (GenTx ByronBlock) +decodeByronGenTx = fromMempoolPayload . canonicalise <$> fromCBOR + where + -- Fill in the 'ByteString' annotation with a canonical encoding of the + -- 'GenTx'. We must reserialise the deserialised 'GenTx' to be sure we + -- have the canonical one. We don't have access to the original + -- 'ByteString' anyway, so having to reserialise here gives us a + -- 'ByteString' we can use. + canonicalise :: CC.AMempoolPayload ByteSpan + -> CC.AMempoolPayload ByteString + canonicalise mp = Lazy.toStrict . slice canonicalBytes <$> mp' + where + canonicalBytes = serialize (void mp) + -- 'unsafeDeserialize' cannot fail, since we just 'serialize'd it. + -- Note that we cannot reuse @mp@, as its 'ByteSpan' might differ from + -- the canonical encoding's 'ByteSpan'. + mp' = unsafeDeserialize canonicalBytes + +encodeByronGenTxId :: GenTxId ByronBlock -> Encoding +encodeByronGenTxId genTxId = mconcat [ + CBOR.encodeListLen 2 + , case genTxId of + ByronTxId i -> toCBOR (0 :: Word8) <> toCBOR i + ByronDlgId i -> toCBOR (1 :: Word8) <> toCBOR i + ByronUpdateProposalId i -> toCBOR (2 :: Word8) <> toCBOR i + ByronUpdateVoteId i -> toCBOR (3 :: Word8) <> toCBOR i + ] + +decodeByronGenTxId :: Decoder s (GenTxId ByronBlock) +decodeByronGenTxId = do + enforceSize "GenTxId (ByronBlock cfg)" 2 + CBOR.decodeWord8 >>= \case + 0 -> ByronTxId <$> fromCBOR + 1 -> ByronDlgId <$> fromCBOR + 2 -> ByronUpdateProposalId <$> fromCBOR + 3 -> ByronUpdateVoteId <$> fromCBOR + tag -> cborError $ DecoderErrorUnknownTag "GenTxId (ByronBlock cfg)" tag + +encodeByronApplyTxError :: ApplyTxErr ByronBlock -> Encoding +encodeByronApplyTxError = toCBOR + +decodeByronApplyTxError :: Decoder s (ApplyTxErr ByronBlock) +decodeByronApplyTxError = fromCBOR diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Orphans.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Orphans.hs index e75def18e03..1eb238ddf62 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Orphans.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Orphans.hs @@ -1,20 +1,125 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.Ledger.Byron.Orphans () where import Codec.Serialise (Serialise, decode, encode) +import Control.Monad (void) +import Data.ByteString (ByteString) +import Data.Coerce +import Data.Text (unpack) +import Formatting + +import qualified Cardano.Binary +import Cardano.Crypto (shortHashF) +import qualified Cardano.Crypto + +import qualified Cardano.Chain.Block as CC +import qualified Cardano.Chain.Common as CC +import qualified Cardano.Chain.Delegation as CC +import qualified Cardano.Chain.MempoolPayload as CC +import qualified Cardano.Chain.Update as CC +import qualified Cardano.Chain.UTxO as CC -import Cardano.Binary (fromCBOR, toCBOR) -import qualified Cardano.Chain.Block as CC.Block -import qualified Cardano.Chain.Common as CC.Common +import Ouroboros.Consensus.Util.Condense {------------------------------------------------------------------------------- Serialise -------------------------------------------------------------------------------} -instance Serialise CC.Block.ChainValidationState where - encode = toCBOR - decode = fromCBOR +instance Serialise CC.ChainValidationState where + encode = Cardano.Binary.toCBOR + decode = Cardano.Binary.fromCBOR + +instance Serialise CC.KeyHash where + encode = Cardano.Binary.toCBOR + decode = Cardano.Binary.fromCBOR + +{------------------------------------------------------------------------------- + Condense +-------------------------------------------------------------------------------} + +instance Condense CC.HeaderHash where + condense = formatToString CC.headerHashF + +instance Condense (CC.ABlock ByteString) where + condense = unpack + . sformat build + . CC.txpTxs + . CC.bodyTxPayload + . CC.blockBody + +instance Condense (CC.AHeader ByteString) where + condense hdr = mconcat [ + "( hash: " <> unpack condensedHash + , ", previousHash: " <> unpack condensedPrevHash + , ", slot: " <> unpack condensedSlot + , ", issuer: " <> condense issuer + , ", delegate: " <> condense delegate + , ")" + ] + where + psigCert = CC.delegationCertificate $ CC.headerSignature hdr + issuer = CC.issuerVK psigCert + delegate = CC.delegateVK psigCert + hdrHash = CC.headerHashAnnotated hdr + + condensedHash = sformat CC.headerHashF $ hdrHash + condensedPrevHash = sformat CC.headerHashF $ CC.headerPrevHash hdr + condensedSlot = sformat build $ + Cardano.Binary.unAnnotated (CC.aHeaderSlot hdr) + +instance Condense (CC.ABoundaryBlock ByteString) where + condense = condense . CC.boundaryHeader + +instance Condense (CC.ABlockOrBoundary ByteString) where + condense (CC.ABOBBlock blk) = mconcat [ + "( header: " <> condense (CC.blockHeader blk) + , ", body: " <> condense blk + , ")" + ] + condense (CC.ABOBBoundary ebb) = + condense ebb + +instance Condense (CC.ABoundaryHeader ByteString) where + condense hdr = mconcat [ + "( ebb: true" + , ", hash: " <> condensedHash + , ", previousHash: " <> condensedPrevHash + , ")" + ] + where + condensedHash = + unpack + . sformat CC.headerHashF + . coerce + . Cardano.Crypto.hashDecoded . fmap CC.wrapBoundaryBytes + $ hdr + + condensedPrevHash = + unpack $ case CC.boundaryPrevHash hdr of + Left _ -> "Genesis" + Right h -> sformat CC.headerHashF h + +instance Condense CC.TxId where + condense hash = "txid:" <> unpack (sformat shortHashF hash) + +instance Condense CC.UpId where + condense hash = "upid:" <> unpack (sformat shortHashF hash) + +instance Condense CC.CertificateId where + condense hash = "certificateid: " <> unpack (sformat shortHashF hash) + +instance Condense CC.VoteId where + condense hash = "voteid: " <> unpack (sformat shortHashF hash) -instance Serialise CC.Common.KeyHash where - encode = toCBOR - decode = fromCBOR +instance Condense (CC.AMempoolPayload a) where + condense (CC.MempoolTx tx) = + "tx: " <> unpack (sformat build (void tx)) + condense (CC.MempoolDlg cert) = + "dlg: " <> unpack (sformat build (void cert)) + condense (CC.MempoolUpdateProposal p) = + "updateproposal: " <> unpack (sformat build (void p)) + condense (CC.MempoolUpdateVote vote) = + "updatevote: " <> unpack (sformat build (void vote)) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/PBFT.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/PBFT.hs new file mode 100644 index 00000000000..51303232674 --- /dev/null +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/PBFT.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | Instances required to support PBFT +module Ouroboros.Consensus.Ledger.Byron.PBFT ( + ByronConsensusProtocol + , toPBftLedgerView + , fromPBftLedgerView + , encodeByronChainState + , decodeByronChainState + ) where + +import Codec.CBOR.Decoding (Decoder) +import Codec.CBOR.Encoding (Encoding) +import Codec.Serialise (decode, encode) +import Data.ByteString (ByteString) + +import Cardano.Binary (Annotated) +import Cardano.Crypto.DSIGN + +import qualified Cardano.Chain.Block as CC +import qualified Cardano.Chain.Delegation as Delegation + +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Crypto.DSIGN.Cardano +import Ouroboros.Consensus.Ledger.Byron.Aux +import Ouroboros.Consensus.Ledger.Byron.Block +import Ouroboros.Consensus.Ledger.Byron.Config +import Ouroboros.Consensus.Protocol.Abstract +import Ouroboros.Consensus.Protocol.PBFT + +type ByronConsensusProtocol = PBft ByronConfig PBftCardanoCrypto +type instance BlockProtocol ByronBlock = ByronConsensusProtocol + +instance HeaderSupportsPBft ByronConfig PBftCardanoCrypto (Header ByronBlock) where + type OptSigned (Header ByronBlock) = Annotated CC.ToSign ByteString + + headerPBftFields cfg ByronHeader{..} = + case byronHeaderRaw of + ABOBBoundaryHdr _ -> Nothing + ABOBBlockHdr hdr -> Just ( + PBftFields { + pbftIssuer = VerKeyCardanoDSIGN + . Delegation.delegateVK + . CC.delegationCertificate + . CC.headerSignature + $ hdr + , pbftGenKey = VerKeyCardanoDSIGN + . CC.headerGenesisKey + $ hdr + , pbftSignature = SignedDSIGN + . SigCardanoDSIGN + . CC.signature + . CC.headerSignature + $ hdr + } + , CC.recoverSignedBytes epochSlots hdr + ) + where + epochSlots = pbftEpochSlots $ pbftExtConfig cfg + +instance SupportedBlock ByronBlock + +toPBftLedgerView :: Delegation.Map -> PBftLedgerView PBftCardanoCrypto +toPBftLedgerView = PBftLedgerView . Delegation.unMap + +fromPBftLedgerView :: PBftLedgerView PBftCardanoCrypto -> Delegation.Map +fromPBftLedgerView = Delegation.Map . pbftDelegates + +encodeByronChainState :: ChainState (BlockProtocol ByronBlock) -> Encoding +encodeByronChainState = encode + +decodeByronChainState :: Decoder s (ChainState (BlockProtocol ByronBlock)) +decodeByronChainState = decode diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Extended.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Extended.hs index 14c002b99c5..ab2bd1c76db 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Extended.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Extended.hs @@ -74,6 +74,23 @@ data BlockPreviouslyApplied = -- ^ The block has not been previously applied to the given ledger state and -- all block validations should be performed. +-- | Update the extended ledger state +-- +-- Updating the extended state happens in 3 steps: +-- +-- * We call 'applyChainTick' to process any changes that happen at epoch +-- boundaries. +-- * We call 'applyLedgerBlock' to process the block itself; this looks at both +-- the header and the body of the block, but /only/ involves the ledger, +-- not the consensus chain state. +-- * Finally, we pass the updated ledger view to then update the consensus +-- chain state. +-- +-- Note: for Byron, this currently deviates from the spec. We apply scheduled +-- updates /before/ checking the signature, but the spec does this the other +-- way around. This means that in the spec delegation updates scheduled for +-- slot @n@ are really only in effect at slot @n+1@. +-- See applyExtLedgerState :: ( UpdateLedger blk , ProtocolLedgerView blk , HasCallStack diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block.hs index 72fde007944..ccf46d5c545 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block.hs @@ -364,10 +364,6 @@ instance Condense ext' => Condense (SimpleBlock' c ext ext') where SimpleStdHeader{..} = simpleHeaderStd SimpleBody{..} = simpleBody -instance Condense (ChainHash (SimpleBlock' c ext ext')) where - condense GenesisHash = "genesis" - condense (BlockHash hdr) = show hdr - {------------------------------------------------------------------------------- Serialise instances -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/BFT.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/BFT.hs index 79e488dc3bf..f02b1602386 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/BFT.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/BFT.hs @@ -106,7 +106,7 @@ instance ( SimpleCrypto c , Signable (BftDSIGN c') (SignedSimpleBft c c') ) => ProtocolLedgerView (SimpleBftBlock c c') where protocolLedgerView _ _ = () - anachronisticProtocolLedgerView _ _ _ = Right $ SB.unbounded () + anachronisticProtocolLedgerView _ _ _ = Right $ SB.maximal () {------------------------------------------------------------------------------- Serialisation diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/PBFT.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/PBFT.hs index 9ddab451fb8..5742bb1b696 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/PBFT.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/PBFT.hs @@ -122,7 +122,7 @@ instance ( SimpleCrypto c protocolLedgerView PBftNodeConfig{..} _ls = pbftExtConfig anachronisticProtocolLedgerView PBftNodeConfig{..} _ _ = - Right $ SB.unbounded pbftExtConfig + Right $ SB.maximal pbftExtConfig {------------------------------------------------------------------------------- Serialisation diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/Praos.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/Praos.hs index 35daebd81f4..be9582ecdab 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/Praos.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/Praos.hs @@ -131,7 +131,7 @@ instance ( SimpleCrypto c equalStakeDist praosExtConfig anachronisticProtocolLedgerView PraosNodeConfig{..} _ _ = - Right $ SB.unbounded $ equalStakeDist praosExtConfig + Right $ SB.maximal $ equalStakeDist praosExtConfig {------------------------------------------------------------------------------- Serialisation diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/PraosRule.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/PraosRule.hs index 4fca71a78af..1238409272e 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/PraosRule.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/PraosRule.hs @@ -85,7 +85,7 @@ instance SimpleCrypto c instance SimpleCrypto c => ProtocolLedgerView (SimplePraosRuleBlock c) where protocolLedgerView _ _ = () - anachronisticProtocolLedgerView _ _ _ = Right $ SB.unbounded () + anachronisticProtocolLedgerView _ _ _ = Right $ SB.maximal () {------------------------------------------------------------------------------- We don't need crypto for this protocol diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node/ProtocolInfo/Byron.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/ProtocolInfo/Byron.hs index 46ef7b3292a..3ee58e01a1e 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node/ProtocolInfo/Byron.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node/ProtocolInfo/Byron.hs @@ -23,7 +23,6 @@ module Ouroboros.Consensus.Node.ProtocolInfo.Byron ( import Control.Exception (Exception) import Control.Monad.Except import Data.Maybe -import qualified Data.Sequence.Strict as Seq import qualified Data.Set as Set import qualified Cardano.Chain.Block as Block @@ -35,7 +34,7 @@ import qualified Cardano.Crypto as Crypto import Ouroboros.Consensus.Crypto.DSIGN.Cardano import Ouroboros.Consensus.Ledger.Byron -import Ouroboros.Consensus.Ledger.Byron.Config +import qualified Ouroboros.Consensus.Ledger.Byron.DelegationHistory as History import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Node.ProtocolInfo.Abstract import Ouroboros.Consensus.NodeId (CoreNodeId) @@ -149,8 +148,8 @@ protocolInfoByron genesisConfig@Genesis.Config { } , pInfoInitLedger = ExtLedgerState { ledgerState = ByronLedgerState { - blsCurrent = initState - , blsSnapshots = Seq.empty + byronLedgerState = initState + , byronDelegationHistory = History.empty } , ouroborosChainState = CS.empty } diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Byron.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Byron.hs index 1f3006a7a66..6d4b70bbef5 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Byron.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Byron.hs @@ -16,8 +16,6 @@ import Ouroboros.Network.Magic (NetworkMagic (..)) import Ouroboros.Consensus.BlockchainTime (SystemStart (..)) import Ouroboros.Consensus.Ledger.Byron -import Ouroboros.Consensus.Ledger.Byron.ContainsGenesis -import Ouroboros.Consensus.Ledger.Byron.Forge import Ouroboros.Consensus.Node.Run.Abstract import Ouroboros.Consensus.Protocol.Abstract @@ -31,7 +29,7 @@ instance RunNode ByronBlock where nodeForgeBlock = forgeByronBlock nodeBlockMatchesHeader = byronBlockMatchesHeader nodeBlockFetchSize = const 2000 -- TODO #593 - nodeIsEBB = \blk -> case bbRaw blk of + nodeIsEBB = \blk -> case byronBlockRaw blk of Cardano.Block.ABOBBlock _ -> False Cardano.Block.ABOBBoundary _ -> True @@ -75,7 +73,7 @@ instance RunNode ByronBlock where nodeDecodeApplyTxError = const decodeByronApplyTxError extractGenesisData :: NodeConfig ByronConsensusProtocol -> Genesis.GenesisData -extractGenesisData = Genesis.configGenesisData . genesisConfig +extractGenesisData = Genesis.configGenesisData . getGenesisConfig extractEpochSlots :: NodeConfig ByronConsensusProtocol -> EpochSlots -extractEpochSlots = Genesis.configEpochSlots . genesisConfig +extractEpochSlots = Genesis.configEpochSlots . getGenesisConfig diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus/src/Ouroboros/Consensus/NodeKernel.hs index 46f57f53714..7c4c7809911 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/NodeKernel.hs @@ -294,6 +294,10 @@ forkBlockProduction IS{..} = -- of 'atomically'. mNewBlock <- withSyncState mempool $ \MempoolSnapshot{snapshotTxs} -> do l@ExtLedgerState{..} <- ChainDB.getCurrentLedger chainDB + -- TODO: I think this is wrong. This uses the ledger view as it was + -- after the last applied block. But that ledger view might have some + -- scheduled updates which should be applied by the time we reach + -- 'currentSlot'. mIsLeader <- runProtocol varDRG $ checkIsLeader cfg diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol.hs index 88dd3ae8989..ec8fb528fa1 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol.hs @@ -19,7 +19,6 @@ import qualified Cardano.Chain.Genesis as Genesis import qualified Cardano.Chain.Update as Update import Ouroboros.Consensus.Ledger.Byron -import Ouroboros.Consensus.Ledger.Byron.Config import Ouroboros.Consensus.Ledger.Mock import Ouroboros.Consensus.Node.ProtocolInfo.Byron import Ouroboros.Consensus.Node.ProtocolInfo.Mock.PBFT () diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Util/Condense.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Util/Condense.hs index 6ded81d129b..cc7f5e70868 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Util/Condense.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Util/Condense.hs @@ -20,15 +20,11 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text, unpack) import Data.Word -import Formatting (sformat) +import Formatting (build, sformat) import Numeric.Natural import Text.Printf (printf) -import qualified Cardano.Chain.Delegation as CC.Delegation -import qualified Cardano.Chain.Update as CC.Update -import qualified Cardano.Chain.UTxO as CC.UTxO - -import Cardano.Crypto (shortHashF) +import Cardano.Crypto (VerificationKey) import Cardano.Crypto.DSIGN (Ed448DSIGN, MockDSIGN, SigDSIGN, pattern SigEd448DSIGN, pattern SigMockDSIGN, SignedDSIGN (..)) @@ -38,15 +34,24 @@ import Cardano.Crypto.KES (MockKES, NeverKES, SigKES, pattern SignKeyMockKES, SignedKES (..), SimpleKES, pattern VerKeyMockKES) -import Ouroboros.Network.Block (BlockNo (..), SlotNo (..)) +import Ouroboros.Network.Block (BlockNo (..), ChainHash (..), + HeaderHash, SlotNo (..)) import Ouroboros.Consensus.Util.HList (All, HList (..)) import qualified Ouroboros.Consensus.Util.HList as HList +{------------------------------------------------------------------------------- + Main class +-------------------------------------------------------------------------------} + -- | Condensed but human-readable output class Condense a where condense :: a -> String +{------------------------------------------------------------------------------- + Rank-1 types +-------------------------------------------------------------------------------} + class Condense1 f where liftCondense :: (a -> String) -> f a -> String @@ -54,6 +59,10 @@ class Condense1 f where condense1 :: (Condense1 f, Condense a) => f a -> String condense1 = liftCondense condense +{------------------------------------------------------------------------------- + Instances for standard types +-------------------------------------------------------------------------------} + instance Condense String where condense = id @@ -100,9 +109,6 @@ instance Condense a => Condense (Maybe a) where instance Condense a => Condense (Set a) where condense = condense1 -instance All Condense as => Condense (HList as) where - condense as = "(" ++ intercalate "," (HList.collapse (Proxy @Condense) condense as) ++ ")" - instance (Condense a, Condense b) => Condense (a, b) where condense (a, b) = condense (a :* b :* Nil) @@ -124,6 +130,38 @@ instance Condense BS.Strict.ByteString where instance Condense BS.Lazy.ByteString where condense bs = show bs ++ "<" ++ show (BS.Lazy.length bs) ++ "b>" +{------------------------------------------------------------------------------- + Consensus specific general purpose types +-------------------------------------------------------------------------------} + +instance All Condense as => Condense (HList as) where + condense as = "(" ++ intercalate "," (HList.collapse (Proxy @Condense) condense as) ++ ")" + +{------------------------------------------------------------------------------- + Orphans for ouroboros-network +-------------------------------------------------------------------------------} + +instance Condense BlockNo where + condense (BlockNo n) = show n + +instance Condense SlotNo where + condense (SlotNo n) = show n + +instance Condense (HeaderHash b) => Condense (ChainHash b) where + condense GenesisHash = "genesis" + condense (BlockHash h) = condense h + +{------------------------------------------------------------------------------- + Orphans for cardano-crypto-wrapper +-------------------------------------------------------------------------------} + +instance Condense VerificationKey where + condense = unpack . sformat build + +{------------------------------------------------------------------------------- + Orphans for cardano-crypto-classes +-------------------------------------------------------------------------------} + instance Condense (SigDSIGN v) => Condense (SignedDSIGN v a) where condense (SignedDSIGN sig) = condense sig @@ -154,21 +192,3 @@ instance Condense (SigDSIGN d) => Condense (SigKES (SimpleKES d)) where instance Condense (Hash h a) where condense = show - -instance Condense CC.UTxO.TxId where - condense hash = "txid:" <> unpack (sformat shortHashF hash) - -instance Condense BlockNo where - condense (BlockNo n) = show n - -instance Condense SlotNo where - condense (SlotNo n) = show n - -instance Condense CC.Update.UpId where - condense hash = "upid:" <> unpack (sformat shortHashF hash) - -instance Condense CC.Delegation.CertificateId where - condense hash = "certificateid: " <> unpack (sformat shortHashF hash) - -instance Condense CC.Update.VoteId where - condense hash = "voteid: " <> unpack (sformat shortHashF hash) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Util/SlotBounded.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Util/SlotBounded.hs index 102c04d6136..929cb8b9bea 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Util/SlotBounded.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Util/SlotBounded.hs @@ -1,40 +1,84 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | Intended for qualified import module Ouroboros.Consensus.Util.SlotBounded ( - SlotBounded(..) + -- * Bounds + Bounds(..) + , InBounds(..) + -- * Slot-bounded values + , SlotBounded(..) + , bounds , bounded - , unbounded + , maximal , at + , contains ) where import Codec.Serialise (Serialise) +import Data.Proxy import GHC.Generics (Generic) import Cardano.Prelude (NoUnexpectedThunks) import Ouroboros.Network.Block (SlotNo) +--import Ouroboros.Network.Point (WithOrigin (..)) + +{------------------------------------------------------------------------------- + Bounds +-------------------------------------------------------------------------------} + +data Bounds = + -- | Both bounds are inclusive + II + + -- | Lower bound is inclusive, upper bound is exclusive + | IX + +class InBounds (bounds :: Bounds) where + inBounds :: proxy bounds -> SlotNo -> (SlotNo, SlotNo) -> Bool + +instance InBounds II where + inBounds _ x (lo, hi) = lo <= x && x <= hi + +instance InBounds IX where + inBounds _ x (lo, hi) = lo <= x && x < hi + +{------------------------------------------------------------------------------- + Slot-bounded values +-------------------------------------------------------------------------------} -- | An item bounded to be valid within particular slots -data SlotBounded a = SlotBounded +data SlotBounded (bounds :: Bounds) a = SlotBounded { sbLower :: !SlotNo , sbUpper :: !SlotNo , sbContent :: !a } deriving (Eq, Functor, Show, Generic, Serialise, NoUnexpectedThunks) +bounds :: SlotBounded bounds a -> (SlotNo, SlotNo) +bounds (SlotBounded lo hi _) = (lo, hi) + +contains :: forall bounds a. InBounds bounds + => SlotBounded bounds a -> SlotNo -> Bool +sb `contains` slot = inBounds (Proxy @bounds) slot (bounds sb) + -- | Construct a slot bounded item. -- --- We choose not to validate that the slot bounds are reasonable here. -bounded :: SlotNo -> SlotNo -> a -> SlotBounded a +-- We choose not to validate that the slot bounds are reasonable here. +bounded :: SlotNo -> SlotNo -> a -> SlotBounded bounds a bounded = SlotBounded -unbounded :: a -> SlotBounded a -unbounded = SlotBounded minBound maxBound +maximal :: a -> SlotBounded bounds a +maximal = SlotBounded minBound maxBound -at :: SlotBounded a -> SlotNo -> Maybe a +at :: InBounds bounds => SlotBounded bounds a -> SlotNo -> Maybe a sb `at` slot = - if (slot <= sbUpper sb && slot >= sbLower sb) - then Just $ sbContent sb - else Nothing + if sb `contains` slot + then Just $ sbContent sb + else Nothing diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/Ledger/Byron.hs b/ouroboros-consensus/test-consensus/Test/Consensus/Ledger/Byron.hs index 28fb26bd76e..04835797dce 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/Ledger/Byron.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/Ledger/Byron.hs @@ -8,10 +8,9 @@ import Codec.CBOR.Decoding (Decoder) import Codec.CBOR.Encoding (Encoding) import Codec.CBOR.Read (deserialiseFromBytes) import Codec.CBOR.Write (toLazyByteString) -import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy -import Cardano.Binary (ByteSpan, fromCBOR, slice, toCBOR) +import Cardano.Binary (fromCBOR, toCBOR) import Cardano.Chain.Block (ABlockOrBoundary (..)) import qualified Cardano.Chain.Block as CC.Block import Cardano.Chain.Common (KeyHash) @@ -23,6 +22,7 @@ import Ouroboros.Network.Point (WithOrigin (..)) import Ouroboros.Consensus.Block (BlockProtocol, Header) import Ouroboros.Consensus.Ledger.Byron +import Ouroboros.Consensus.Ledger.Byron.Aux import Ouroboros.Consensus.Mempool.API (ApplyTxErr) import Ouroboros.Consensus.Protocol.Abstract (ChainState) import Ouroboros.Consensus.Protocol.PBFT @@ -92,27 +92,6 @@ roundtrip' enc dec a = case deserialiseFromBytes dec bs of where bs = toLazyByteString (enc a) -annotate :: forall f. Functor f - => (f () -> Encoding) - -> (forall s. Decoder s (f ByteSpan)) - -> f () - -> f Strict.ByteString -annotate encode decoder = - (\bs -> splice bs (deserialiseFromBytes decoder bs)) - . toLazyByteString - . encode - where - splice :: Lazy.ByteString - -> Either err (Lazy.ByteString, f ByteSpan) - -> f Strict.ByteString - splice _ (Left _err) = - error "annotate: serialization roundtrip failure" - splice bs (Right (bs', x)) - | Lazy.null bs' - = Lazy.toStrict . slice bs <$> x - | otherwise - = error ("left-over bytes: " <> show bs') - {------------------------------------------------------------------------------- Serialisation roundtrips -------------------------------------------------------------------------------} @@ -167,7 +146,7 @@ instance Arbitrary ByronBlock where hedgehog (CC.genBlock protocolMagicId epochSlots) genBoundaryBlock :: Gen ByronBlock genBoundaryBlock = - mkByronBlock epochSlots . ABOBBoundary . annotateBoundary protocolMagicId <$> + mkByronBlock epochSlots . ABOBBoundary . reAnnotateBoundary protocolMagicId <$> hedgehog (CC.genBoundaryBlock) @@ -179,15 +158,15 @@ instance Arbitrary (Header ByronBlock) where where genHeader :: Gen (Header ByronBlock) genHeader = - mkByronHeader epochSlots . Right . - annotate + mkByronHeader epochSlots . ABOBBlockHdr . + reAnnotateUsing (CC.Block.toCBORHeader epochSlots) (CC.Block.fromCBORAHeader epochSlots) <$> hedgehog (CC.genHeader protocolMagicId epochSlots) genBoundaryHeader :: Gen (Header ByronBlock) genBoundaryHeader = - mkByronHeader epochSlots . Left . - annotate + mkByronHeader epochSlots . ABOBBoundaryHdr . + reAnnotateUsing (CC.Block.toCBORABoundaryHeader protocolMagicId) CC.Block.fromCBORABoundaryHeader <$> hedgehog CC.genBoundaryHeader @@ -204,7 +183,7 @@ instance Arbitrary (PBftChainState PBftCardanoCrypto) where instance Arbitrary (GenTx ByronBlock) where arbitrary = - mkByronGenTx . annotate toCBOR fromCBOR <$> + fromMempoolPayload . reAnnotateUsing toCBOR fromCBOR <$> hedgehog (CC.genMempoolPayload protocolMagicId) instance Arbitrary (GenTxId ByronBlock) where @@ -218,13 +197,13 @@ instance Arbitrary (GenTxId ByronBlock) where genCertificateId = CC.genAbstractHash (CC.genCertificate protocolMagicId) genUpdateVoteId = CC.genAbstractHash (CC.genVote protocolMagicId) -instance Arbitrary ByronApplyTxError where +instance Arbitrary ApplyMempoolPayloadErr where arbitrary = oneof - [ ByronApplyTxError <$> hedgehog CC.genUTxOValidationError - , ByronApplyDlgError <$> hedgehog CC.genError + [ MempoolTxErr <$> hedgehog CC.genUTxOValidationError + , MempoolDlgErr <$> hedgehog CC.genError -- TODO there is no generator for -- Cardano.Chain.Update.Validation.Interface.Error and we can't write one -- either because the different Error types it wraps are not exported. - -- , ByronApplyUpdateProposalError <$> arbitrary - -- , ByronApplyUpdateVoteError <$> arbitrary + -- , MempoolUpdateProposalErr <$> arbitrary + -- , MempoolUpdateVoteErr <$> arbitrary ] diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/TestBlock.hs index d5035c2c9b8..12f77790a8d 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/TestBlock.hs +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/TestBlock.hs @@ -307,7 +307,7 @@ instance UpdateLedger TestBlock where instance ProtocolLedgerView TestBlock where protocolLedgerView _ _ = () - anachronisticProtocolLedgerView _ _ _ = Right $ SB.unbounded () + anachronisticProtocolLedgerView _ _ _ = Right $ SB.maximal () testInitLedger :: LedgerState TestBlock testInitLedger = TestLedger GenesisPoint GenesisHash diff --git a/ouroboros-consensus/test-util/Test/Util/TestBlock.hs b/ouroboros-consensus/test-util/Test/Util/TestBlock.hs index f2ffdf46d78..aa925c2af85 100644 --- a/ouroboros-consensus/test-util/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/test-util/Test/Util/TestBlock.hs @@ -272,7 +272,7 @@ instance UpdateLedger TestBlock where instance ProtocolLedgerView TestBlock where protocolLedgerView _ _ = () - anachronisticProtocolLedgerView _ _ _ = Right $ SB.unbounded () + anachronisticProtocolLedgerView _ _ _ = Right $ SB.maximal () testInitLedger :: LedgerState TestBlock testInitLedger = TestLedger Block.genesisPoint GenesisHash diff --git a/ouroboros-consensus/tools/db-convert/Main.hs b/ouroboros-consensus/tools/db-convert/Main.hs index b744fb1b80e..8c06220a84e 100644 --- a/ouroboros-consensus/tools/db-convert/Main.hs +++ b/ouroboros-consensus/tools/db-convert/Main.hs @@ -215,7 +215,7 @@ validateChainDb dbDir cfg onlyImmDB verbose = -- Integration , ChainDB.cdbNodeConfig = pInfoConfig byronProtocolInfo , ChainDB.cdbEpochInfo = fixedSizeEpochInfo . EpochSize . unEpochSlots $ epochSlots - , ChainDB.cdbIsEBB = \blk -> case Byron.bbRaw blk of + , ChainDB.cdbIsEBB = \blk -> case Byron.byronBlockRaw blk of CC.ABOBBlock _ -> Nothing CC.ABOBBoundary ebb -> Just (Byron.ByronHash (CC.boundaryHashAnnotated ebb)) -- Misc