diff --git a/cardano-ledger/cardano-ledger.cabal b/cardano-ledger/cardano-ledger.cabal index c14d714a..59776add 100644 --- a/cardano-ledger/cardano-ledger.cabal +++ b/cardano-ledger/cardano-ledger.cabal @@ -26,6 +26,7 @@ library hs-source-dirs: src exposed-modules: Cardano.Chain.Block + Cardano.Chain.Byron.API Cardano.Chain.Common Cardano.Chain.Constants Cardano.Chain.Delegation @@ -44,7 +45,10 @@ library Cardano.Chain.UTxO.Validation Cardano.Chain.Update Cardano.Chain.Update.Proposal + Cardano.Chain.Update.Validation.Endorsement Cardano.Chain.Update.Validation.Interface + Cardano.Chain.Update.Validation.Registration + Cardano.Chain.Update.Validation.Voting Cardano.Chain.Update.Vote Cardano.Chain.ValidationMode @@ -115,10 +119,7 @@ library Cardano.Chain.Update.SoftforkRule Cardano.Chain.Update.SoftwareVersion Cardano.Chain.Update.SystemTag - Cardano.Chain.Update.Validation.Endorsement Cardano.Chain.Update.Validation.Interface.ProtocolVersionBump - Cardano.Chain.Update.Validation.Registration - Cardano.Chain.Update.Validation.Voting build-depends: base >=4.11 && <5 , base58-bytestring @@ -131,6 +132,7 @@ library , cardano-crypto , cardano-crypto-wrapper , cardano-prelude + , cborg , containers , contra-tracer , concurrency @@ -177,6 +179,7 @@ test-suite cardano-ledger-test Test.Cardano.Chain.Block.Model.Examples Test.Cardano.Chain.Block.Validation Test.Cardano.Chain.Block.ValidationMode + Test.Cardano.Chain.Byron.API Test.Cardano.Chain.Buildable diff --git a/cardano-ledger/src/Cardano/Chain/Byron/API.hs b/cardano-ledger/src/Cardano/Chain/Byron/API.hs new file mode 100644 index 00000000..f80b7504 --- /dev/null +++ b/cardano-ledger/src/Cardano/Chain/Byron/API.hs @@ -0,0 +1,639 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Auxiliary definitions to make working with the Byron ledger easier +module Cardano.Chain.Byron.API ( + -- * Extract info from genesis config + allowedDelegators + , boundaryBlockSlot + -- * Extract info from chain state + , getDelegationMap + , getProtocolParams + , getScheduledDelegations + , getMaxBlockSize + -- * Applying blocks + , applyChainTick + , validateBlock + , validateBoundary + , previewDelegationMap + -- * 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.ByteString (ByteString) +import qualified Data.ByteString.Lazy as Lazy +import Data.Either (isRight) +import Data.Sequence (Seq) +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Word +import GHC.Generics (Generic) + +import Cardano.Binary +import Cardano.Crypto.ProtocolMagic +import Cardano.Prelude + +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 + +{------------------------------------------------------------------------------- + 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 + +getMaxBlockSize :: CC.ChainValidationState -> Word32 +getMaxBlockSize = + fromIntegral + . Update.ppMaxBlockSize + . getProtocolParams + +{------------------------------------------------------------------------------- + Update parts of the chain state +-------------------------------------------------------------------------------} + +setUTxO :: Utxo.UTxO + -> CC.ChainValidationState -> CC.ChainValidationState +setUTxO newUTxO cvs = cvs { CC.cvsUtxo = newUTxO } + +setDelegationState :: D.Iface.State + -> CC.ChainValidationState -> CC.ChainValidationState +setDelegationState newDlg cvs = cvs { CC.cvsDelegationState = newDlg } + +setUpdateState :: U.Iface.State + -> CC.ChainValidationState -> CC.ChainValidationState +setUpdateState newUpdate cvs = cvs { CC.cvsUpdateState = newUpdate } + +{------------------------------------------------------------------------------- + Applying blocks +-------------------------------------------------------------------------------} + +mkEpochEnvironment :: Gen.Config + -> CC.ChainValidationState + -> CC.EpochEnvironment +mkEpochEnvironment cfg cvs = 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 cvs) + } + where + delegationMap :: Delegation.Map + delegationMap = D.Iface.delegationMap $ CC.cvsDelegationState cvs + +mkBodyState :: CC.ChainValidationState -> CC.BodyState +mkBodyState cvs = CC.BodyState { + CC.utxo = CC.cvsUtxo cvs + , CC.updateState = CC.cvsUpdateState cvs + , CC.delegationState = CC.cvsDelegationState cvs + } + +-- 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 + } + +-- | Apply chain tick +-- +-- This is the part of block processing that depends only on the slot number of +-- the block: We update +-- +-- * The update state +-- * The delegation state +-- * The last applied slot number +-- +-- NOTE: The spec currently only updates the update state here; this is not good +-- enough. Fortunately, updating the delegation state and slot number here +-- (currently done in body processing) is at least /conform/ spec, as these +-- updates are conform spec. See +-- +-- +-- +applyChainTick :: Gen.Config + -> CC.SlotNumber + -> CC.ChainValidationState + -> CC.ChainValidationState +applyChainTick cfg slotNo cvs = cvs { + CC.cvsLastSlot = slotNo + , CC.cvsUpdateState = CC.epochTransition + (mkEpochEnvironment cfg cvs) + (CC.cvsUpdateState cvs) + slotNo + , CC.cvsDelegationState = D.Iface.tickDelegation + currentEpoch + slotNo + (CC.cvsDelegationState cvs) + } + + where + currentEpoch = CC.slotNumberEpoch (Gen.configEpochSlots cfg) slotNo + +-- | Validate header +-- +-- NOTE: Header validation does not produce any state changes; the only state +-- changes arising from processing headers come from 'applyChainTick'. +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 cvs = 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. + validatePrevHashMatch block cvs + + validateHeader validationMode updState (CC.blockHeader block) + bodyState' <- validateBody validationMode block bodyEnv bodyState + return cvs { + 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 cvs + bodyEnv = mkBodyEnvironment + cfg + (getProtocolParams cvs) + (CC.blockSlot block) + bodyState = mkBodyState cvs + +validatePrevHashMatch :: MonadError CC.ChainValidationError m + => CC.ABlock ByteString + -> CC.ChainValidationState -> m () +validatePrevHashMatch block cvs = do + case ( CC.cvsPreviousHash cvs + , 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 + +-- | 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 cvs = do + -- TODO: Unfortunately, 'updateChainBoundary' doesn't take a hash as an + -- argument but recomputes it. + cvs' <- CC.updateChainBoundary cvs 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 cvs' { + CC.cvsLastSlot = boundaryBlockSlot epochSlots (CC.boundaryEpoch hdr) + } + where + hdr = CC.boundaryHeader blk + epochSlots = Gen.configEpochSlots cfg + +-- | Preview the delegation map at a slot assuming no new delegations are +-- | scheduled. +previewDelegationMap :: CC.SlotNumber + -> CC.ChainValidationState + -> Delegation.Map +previewDelegationMap slot cvs = + let ds = D.Iface.activateDelegations slot $ CC.cvsDelegationState cvs + in D.Iface.delegationMap ds + +{------------------------------------------------------------------------------- + Applying transactions +-------------------------------------------------------------------------------} + +mkUtxoEnvironment :: Gen.Config + -> CC.ChainValidationState + -> Utxo.Environment +mkUtxoEnvironment cfg cvs = 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 cvs + +mkDelegationEnvironment :: Gen.Config + -> CC.ChainValidationState + -> D.Iface.Environment +mkDelegationEnvironment cfg cvs = 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 cvs + currentEpoch = CC.slotNumberEpoch (Gen.configEpochSlots cfg) currentSlot + +mkUpdateEnvironment :: Gen.Config + -> CC.ChainValidationState + -> U.Iface.Environment +mkUpdateEnvironment cfg cvs = 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 cvs + numGenKeys = toNumGenKeys $ Set.size (allowedDelegators cfg) + delegationMap = getDelegationMap cvs + + -- 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) = panic $ + "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 cvs = + flip runReaderT validationMode $ + (`setUTxO` cvs) <$> + Utxo.updateUTxO utxoEnv utxo txs + where + utxoEnv = mkUtxoEnvironment cfg cvs + utxo = CC.cvsUtxo cvs + +applyCertificate :: MonadError D.Sched.Error m + => Gen.Config + -> [Delegation.ACertificate ByteString] + -> CC.ChainValidationState -> m CC.ChainValidationState +applyCertificate cfg certs cvs = + (`setDelegationState` cvs) <$> + D.Iface.updateDelegation dlgEnv dlgState certs + where + dlgEnv = mkDelegationEnvironment cfg cvs + dlgState = CC.cvsDelegationState cvs + +applyUpdateProposal :: MonadError U.Iface.Error m + => Gen.Config + -> Update.AProposal ByteString + -> CC.ChainValidationState -> m CC.ChainValidationState +applyUpdateProposal cfg proposal cvs = + (`setUpdateState` cvs) <$> + U.Iface.registerProposal updateEnv updateState proposal + where + updateEnv = mkUpdateEnvironment cfg cvs + updateState = CC.cvsUpdateState cvs + +applyUpdateVote :: MonadError U.Iface.Error m + => Gen.Config + -> Update.AVote ByteString + -> CC.ChainValidationState -> m CC.ChainValidationState +applyUpdateVote cfg vote cvs = + (`setUpdateState` cvs) <$> + U.Iface.registerVote updateEnv updateState vote + where + updateEnv = mkUpdateEnvironment cfg cvs + updateState = CC.cvsUpdateState cvs + +{------------------------------------------------------------------------------- + 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 :: forall a. CC.AMempoolPayload a -> ByteString + 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. T.Text -> x + roundtripFailure err = panic $ T.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 -> fail $ "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/cardano-ledger/src/Cardano/Chain/Delegation/Validation/Interface.hs b/cardano-ledger/src/Cardano/Chain/Delegation/Validation/Interface.hs index db0df6f7..9461ccd9 100644 --- a/cardano-ledger/src/Cardano/Chain/Delegation/Validation/Interface.hs +++ b/cardano-ledger/src/Cardano/Chain/Delegation/Validation/Interface.hs @@ -10,9 +10,11 @@ module Cardano.Chain.Delegation.Validation.Interface -- * Blockchain Interface Environment(..) , State(..) + , activateDelegations + , delegates , delegationMap , initialState - , delegates + , tickDelegation , updateDelegation ) where @@ -139,30 +141,13 @@ updateDelegation -> m State updateDelegation env is certificates = do -- Schedule new certificates - Scheduling.State delegations keyEpochs <- foldM + ss' <- foldM (Scheduling.scheduleCertificate schedulingEnv) (schedulingState is) certificates - -- Activate certificates up to this slot - let - as = foldl - Activation.activateDelegation - (activationState is) - (Seq.filter ((<= currentSlot) . Scheduling.sdSlot) delegations) - - -- Remove stale values from 'Scheduling.State' - let - ss' = Scheduling.State - { Scheduling.scheduledDelegations = Seq.filter - ((currentSlot + 1 <=) . Scheduling.sdSlot) - delegations - , Scheduling.keyEpochDelegations = Set.filter - ((>= currentEpoch) . fst) - keyEpochs - } - - pure $ State {schedulingState = ss', activationState = as} + pure $ tickDelegation currentEpoch currentSlot + is { schedulingState = ss' } where Environment { protocolMagic, allowedDelegators, k, currentEpoch, currentSlot } = env @@ -174,3 +159,37 @@ updateDelegation env is certificates = do , Scheduling.currentSlot = currentSlot , Scheduling.k = k } + +-- | Perform delegation update without adding certificates +tickDelegation :: EpochNumber -> SlotNumber -> State -> State +tickDelegation currentEpoch currentSlot = + prune . activateDelegations currentSlot + where + prune s = + let ss' = pruneScheduledDelegations currentEpoch currentSlot (schedulingState s) + in s{ schedulingState = ss'} + +-- Activate certificates up to this slot +activateDelegations :: SlotNumber -> State -> State +activateDelegations currentSlot s@(State ss as) = + let Scheduling.State delegations _keyEpochs = ss + as' = foldl Activation.activateDelegation as + (Seq.filter ((<= currentSlot) . Scheduling.sdSlot) delegations) + in s { activationState = as' } + +-- Remove stale values from 'Scheduling.State' +pruneScheduledDelegations + :: EpochNumber + -> SlotNumber + -> Scheduling.State + -> Scheduling.State +pruneScheduledDelegations currentEpoch currentSlot ss = + let Scheduling.State delegations keyEpochs = ss + in Scheduling.State + { Scheduling.scheduledDelegations = Seq.filter + ((currentSlot + 1 <=) . Scheduling.sdSlot) + delegations + , Scheduling.keyEpochDelegations = Set.filter + ((>= currentEpoch) . fst) + keyEpochs + } diff --git a/cardano-ledger/src/Cardano/Chain/Update/Validation/Endorsement.hs b/cardano-ledger/src/Cardano/Chain/Update/Validation/Endorsement.hs index 713b7f36..7cb2e414 100644 --- a/cardano-ledger/src/Cardano/Chain/Update/Validation/Endorsement.hs +++ b/cardano-ledger/src/Cardano/Chain/Update/Validation/Endorsement.hs @@ -11,7 +11,7 @@ module Cardano.Chain.Update.Validation.Endorsement , Endorsement (..) , CandidateProtocolUpdate (..) , register - , Error + , Error (..) ) where diff --git a/cardano-ledger/src/Cardano/Chain/Update/Validation/Registration.hs b/cardano-ledger/src/Cardano/Chain/Update/Validation/Registration.hs index 64032f97..99a2ce7a 100644 --- a/cardano-ledger/src/Cardano/Chain/Update/Validation/Registration.hs +++ b/cardano-ledger/src/Cardano/Chain/Update/Validation/Registration.hs @@ -9,7 +9,7 @@ -- This is an implementation of the rules defined in the Byron ledger -- specification module Cardano.Chain.Update.Validation.Registration - ( Error + ( Error (..) , Environment (..) , State (..) , ApplicationVersions @@ -18,6 +18,7 @@ module Cardano.Chain.Update.Validation.Registration , SoftwareUpdateProposals , registerProposal , TooLarge (..) + , Adopted (..) ) where diff --git a/cardano-ledger/test/Test/Cardano/Chain/Byron/API.hs b/cardano-ledger/test/Test/Cardano/Chain/Byron/API.hs new file mode 100644 index 00000000..22c869df --- /dev/null +++ b/cardano-ledger/test/Test/Cardano/Chain/Byron/API.hs @@ -0,0 +1,112 @@ +{-# Language TypeApplications #-} +{-# Language OverloadedStrings #-} +{-# Language RankNTypes #-} + + +module Test.Cardano.Chain.Byron.API + ( genApplyMempoolPayloadErr + , ts_roundTripApplyMempoolPayloadErrCompat + , ts_scheduledDelegations + , tests + ) + where + +import Cardano.Prelude + +import Cardano.Crypto (ProtocolMagicId) +import Cardano.Chain.Byron.API + ( ApplyMempoolPayloadErr (..) + , getDelegationMap + , applyChainTick + , previewDelegationMap + ) +import Cardano.Spec.Chain.STS.Rule.Chain (CHAIN) +import qualified Control.State.Transition.Trace as STS +import qualified Control.State.Transition.Generator as STS + +import Cardano.Chain.Block (ChainValidationState (..), initialChainValidationState) +import Cardano.Chain.Slotting (SlotNumber(..), SlotCount (..)) + +import Test.Cardano.Chain.Elaboration.Block (abEnvToCfg, transactionIds) +import Test.Cardano.Chain.UTxO.Gen (genUTxOValidationError) +import qualified Test.Cardano.Chain.Delegation.Gen as Dlg +import qualified Test.Cardano.Chain.Update.Gen as UpdateIface +import Test.Cardano.Crypto.Gen (feedPM) +import Test.Options (eachOfTS, TSProperty) +import Test.Cardano.Binary.Helpers.GoldenRoundTrip (roundTripsCBORShow) + + +import Hedgehog (Gen, property, forAll, Group(..), (===)) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +import Test.Options (withTestsTS, TSGroup) + +import Test.Cardano.Chain.UTxO.Model (elaborateInitialUTxO) +import Test.Cardano.Chain.Block.Model (elaborateAndUpdate) + +import Cardano.Chain.Genesis (configSlotSecurityParam) +import qualified Cardano.Chain.Genesis as Genesis + +tests :: TSGroup +tests scenario = Group "Test.Cardano.Chain.Byron.API" + [ ( "ts_chainTick", ts_chainTick scenario) + , ( "ts_roundTripApplyMempoolPayloadErrCompat", ts_roundTripApplyMempoolPayloadErrCompat scenario) + , ( "ts_scheduledDelegations", ts_scheduledDelegations scenario) + ] + +ts_roundTripApplyMempoolPayloadErrCompat :: TSProperty +ts_roundTripApplyMempoolPayloadErrCompat = eachOfTS + 20 + (feedPM genApplyMempoolPayloadErr) + roundTripsCBORShow + +genApplyMempoolPayloadErr :: ProtocolMagicId -> Gen ApplyMempoolPayloadErr +genApplyMempoolPayloadErr pm = Gen.choice + [ MempoolTxErr <$> genUTxOValidationError + , MempoolDlgErr <$> Dlg.genError + , MempoolUpdateProposalErr <$> UpdateIface.genError pm + , MempoolUpdateVoteErr <$> UpdateIface.genError pm + ] + +setupChainValidationState :: STS.Trace CHAIN -> (ChainValidationState, Genesis.Config) +setupChainValidationState sampleTrace = + let chainEnv@(_, abstractInitialUTxO,_,_,_) = STS._traceEnv sampleTrace + config = abEnvToCfg chainEnv + (initialUTxO, txIdMap) = elaborateInitialUTxO abstractInitialUTxO + initialAbstractToConcreteIdMaps = mempty { transactionIds = txIdMap } + initialStateNoUTxO = either (panic . show) identity $ initialChainValidationState config + initialState = initialStateNoUTxO { cvsUtxo = initialUTxO } + (cvs, _) = either (panic . show) identity $ + foldM + (elaborateAndUpdate config) + (initialState, initialAbstractToConcreteIdMaps) + (STS.preStatesAndSignals STS.OldestFirst sampleTrace) + in (cvs, config) + +-- | getDelegationMap . applyChainTick slot == previewDelegationMap slot +ts_scheduledDelegations :: TSProperty +ts_scheduledDelegations = withTestsTS 100 . property $ do + let traceLength = 10 :: Word64 + sampleTrace <- forAll $ STS.trace @CHAIN () traceLength + let (cvs, config) = setupChainValidationState sampleTrace + n = unSlotNumber . cvsLastSlot $ cvs + k = unSlotCount . configSlotSecurityParam $ config + slotNumber <- forAll $ SlotNumber <$> Gen.word64 (Range.linear n (n + 2*k - 1)) + let tickedDelegationMap = getDelegationMap $ applyChainTick config slotNumber cvs + anachronisticDelegationMap = previewDelegationMap slotNumber cvs + tickedDelegationMap === anachronisticDelegationMap + +-- | Given three slots, a < b < c, ticking from a to b and then b to c +-- | should be the same as ticking from a to c. +ts_chainTick :: TSProperty +ts_chainTick = withTestsTS 100 . property $ do + let traceLength = 10 :: Word64 + sampleTrace <- forAll $ STS.trace @CHAIN () traceLength + let (cvs, config) = setupChainValidationState sampleTrace + n0 = unSlotNumber . cvsLastSlot $ cvs + k = unSlotCount . configSlotSecurityParam $ config + n2 <- forAll $ Gen.word64 (Range.linear n0 (n0 + 2*k)) + n1 <- forAll $ Gen.word64 (Range.linear n0 n2) + let tick n = applyChainTick config (SlotNumber n) + (tick n2 . tick n1) cvs === tick n2 cvs diff --git a/cardano-ledger/test/Test/Cardano/Chain/Update/Gen.hs b/cardano-ledger/test/Test/Cardano/Chain/Update/Gen.hs index 97554a62..58a605e6 100644 --- a/cardano-ledger/test/Test/Cardano/Chain/Update/Gen.hs +++ b/cardano-ledger/test/Test/Cardano/Chain/Update/Gen.hs @@ -1,6 +1,7 @@ module Test.Cardano.Chain.Update.Gen ( genCanonicalProtocolParameters , genApplicationName + , genError , genProtocolVersion , genProtocolParameters , genProtocolParametersUpdate @@ -27,25 +28,35 @@ import qualified Hedgehog.Range as Range import Cardano.Chain.Update ( ApplicationName(..) + , ApplicationNameError(..) + , InstallerHash(..) , Payload , Proof , Proposal , ProposalBody(..) - , ProtocolParametersUpdate(..) , ProtocolParameters(..) + , ProtocolParametersUpdate(..) , ProtocolVersion(..) , SoftforkRule(..) , SoftwareVersion(..) + , SoftwareVersionError(..) , SystemTag(..) + , SystemTagError(..) , UpId - , InstallerHash(..) , Vote , applicationNameMaxLength - , unsafeProposal , mkVote , payload , systemTagMaxLength + , unsafeProposal ) +import Cardano.Chain.Update.Validation.Interface (Error(..)) +import qualified Cardano.Chain.Update.Validation.Registration as Registration +import qualified Cardano.Chain.Update.Validation.Voting as Voting +import qualified Cardano.Chain.Update.Validation.Endorsement as Endorsement +import Cardano.Chain.Slotting (SlotNumber(..)) + + import Cardano.Crypto (ProtocolMagicId) import Test.Cardano.Chain.Common.Gen @@ -53,6 +64,7 @@ import Test.Cardano.Chain.Common.Gen , genLovelacePortion , genScriptVersion , genTxFeePolicy + , genKeyHash ) import Test.Cardano.Chain.Slotting.Gen (genEpochNumber, genSlotNumber) @@ -65,6 +77,8 @@ import Test.Cardano.Crypto.Gen ) + + genApplicationName :: Gen ApplicationName genApplicationName = ApplicationName @@ -181,3 +195,61 @@ genUpsData = genVote :: ProtocolMagicId -> Gen Vote genVote pm = mkVote pm <$> genSigningKey <*> genUpId pm <*> Gen.bool + +genError :: ProtocolMagicId -> Gen Error +genError pm = Gen.choice + [ Registration <$> genRegistrationError + , Voting <$> genVotingError pm + , Endorsement <$> genEndorsementError + , NumberOfGenesisKeysTooLarge <$> genRegistrationTooLarge + ] + +genRegistrationError :: Gen Registration.Error +genRegistrationError = Gen.choice + [ Registration.DuplicateProtocolVersion <$> genProtocolVersion + , Registration.DuplicateSoftwareVersion <$> genSoftwareVersion + , Registration.InvalidProposer <$> genKeyHash + , Registration.InvalidProtocolVersion + <$> genProtocolVersion + <*> (Registration.Adopted <$> genProtocolVersion) + , Registration.InvalidScriptVersion <$> genWord16 <*> genWord16 + , pure Registration.InvalidSignature + , Registration.InvalidSoftwareVersion <$> + ( Gen.map (Range.linear 1 20) $ do + name <- genApplicationName + version <- genWord32 + slotNo <- SlotNumber <$> Gen.word64 Range.constantBounded + meta <- Gen.map (Range.linear 1 10) $ + (,) <$> genSystemTag <*> genInstallerHash + pure (name, (version, slotNo, meta)) + ) <*> genSoftwareVersion + , Registration.MaxBlockSizeTooLarge <$> (Registration.TooLarge <$> genNatural <*> genNatural) + , Registration.MaxTxSizeTooLarge <$> (Registration.TooLarge <$> genNatural <*> genNatural) + , pure Registration.ProposalAttributesUnknown + , Registration.ProposalTooLarge <$> (Registration.TooLarge <$> genNatural <*> genNatural) + , (Registration.SoftwareVersionError . SoftwareVersionApplicationNameError) + <$> Gen.choice + [ ApplicationNameTooLong <$> Gen.text (Range.linear 0 20) Gen.alphaNum + , ApplicationNameNotAscii <$> Gen.text (Range.linear 0 20) Gen.alphaNum + ] + , Registration.SystemTagError <$> Gen.choice + [ SystemTagNotAscii <$> Gen.text (Range.linear 0 20) Gen.alphaNum + , SystemTagTooLong <$> Gen.text (Range.linear 0 20) Gen.alphaNum + ] + ] + +genVotingError :: ProtocolMagicId -> Gen Voting.Error +genVotingError pm = Gen.choice + [ pure Voting.VotingInvalidSignature + , Voting.VotingProposalNotRegistered <$> genUpId pm + , Voting.VotingVoterNotDelegate <$> genKeyHash + ] + +genEndorsementError :: Gen Endorsement.Error +genEndorsementError = Endorsement.MultipleProposalsForProtocolVersion <$> + genProtocolVersion + +genRegistrationTooLarge :: Gen (Registration.TooLarge Int) +genRegistrationTooLarge = Registration.TooLarge + <$> Gen.int Range.constantBounded + <*> Gen.int Range.constantBounded diff --git a/cardano-ledger/test/cardano-ledger-test.cabal b/cardano-ledger/test/cardano-ledger-test.cabal index 1ca347cb..2006d999 100644 --- a/cardano-ledger/test/cardano-ledger-test.cabal +++ b/cardano-ledger/test/cardano-ledger-test.cabal @@ -25,6 +25,8 @@ library Test.Cardano.Chain.Block.Validation Test.Cardano.Chain.Block.ValidationMode + Test.Cardano.Chain.Byron.API + Test.Cardano.Chain.Buildable Test.Cardano.Chain.Common.Address diff --git a/cardano-ledger/test/test.hs b/cardano-ledger/test/test.hs index 20ea5f5c..a3504694 100644 --- a/cardano-ledger/test/test.hs +++ b/cardano-ledger/test/test.hs @@ -34,6 +34,7 @@ import qualified Test.Cardano.Chain.UTxO.ValidationMode import qualified Test.Cardano.Chain.Update.CBOR import qualified Test.Cardano.Chain.Update.Properties import qualified Test.Cardano.Chain.Elaboration.Delegation +import qualified Test.Cardano.Chain.Byron.API main :: IO () main = @@ -65,4 +66,5 @@ main = , Test.Cardano.Chain.UTxO.ValidationMode.tests , Test.Cardano.Chain.Update.CBOR.tests , Test.Cardano.Chain.Update.Properties.tests + , Test.Cardano.Chain.Byron.API.tests ] diff --git a/nix/.stack.nix/cardano-ledger.nix b/nix/.stack.nix/cardano-ledger.nix index ce069d8c..14627fff 100644 --- a/nix/.stack.nix/cardano-ledger.nix +++ b/nix/.stack.nix/cardano-ledger.nix @@ -28,6 +28,7 @@ (hsPkgs.cardano-crypto) (hsPkgs.cardano-crypto-wrapper) (hsPkgs.cardano-prelude) + (hsPkgs.cborg) (hsPkgs.containers) (hsPkgs.contra-tracer) (hsPkgs.concurrency)