{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Ouroboros.Consensus.Shelley.Ledger.Forge (
forgeShelleyBlock
) where
import Control.Exception
import Control.Monad.Except
import Data.List (foldl')
import qualified Data.Sequence.Strict as Seq
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.SupportsMempool
import Ouroboros.Consensus.Util.Assert
import qualified Shelley.Spec.Ledger.BlockChain as SL
import Ouroboros.Consensus.Shelley.Eras (EraCrypto)
import Ouroboros.Consensus.Shelley.Ledger.Block
import Ouroboros.Consensus.Shelley.Ledger.Config
import Ouroboros.Consensus.Shelley.Ledger.Integrity
import Ouroboros.Consensus.Shelley.Ledger.Mempool
import Ouroboros.Consensus.Shelley.Protocol
import Ouroboros.Consensus.Shelley.Protocol.HotKey (HotKey)
forgeShelleyBlock ::
forall m era. (ShelleyBasedEra era, Monad m)
=> HotKey (EraCrypto era) m
-> TPraosCanBeLeader (EraCrypto era)
-> TopLevelConfig (ShelleyBlock era)
-> BlockNo
-> SlotNo
-> TickedLedgerState (ShelleyBlock era)
-> [GenTx (ShelleyBlock era)]
-> TPraosIsLeader (EraCrypto era)
-> m (ShelleyBlock era)
forgeShelleyBlock :: HotKey (EraCrypto era) m
-> TPraosCanBeLeader (EraCrypto era)
-> TopLevelConfig (ShelleyBlock era)
-> BlockNo
-> SlotNo
-> TickedLedgerState (ShelleyBlock era)
-> [GenTx (ShelleyBlock era)]
-> TPraosIsLeader (EraCrypto era)
-> m (ShelleyBlock era)
forgeShelleyBlock HotKey (EraCrypto era) m
hotKey TPraosCanBeLeader (EraCrypto era)
canBeLeader TopLevelConfig (ShelleyBlock era)
cfg BlockNo
curNo SlotNo
curSlot TickedLedgerState (ShelleyBlock era)
tickedLedger [GenTx (ShelleyBlock era)]
txs TPraosIsLeader (EraCrypto era)
isLeader = do
TPraosFields (EraCrypto era) (BHBody (EraCrypto era))
tpraosFields <- HotKey (EraCrypto era) m
-> CanBeLeader (TPraos (EraCrypto era))
-> IsLeader (TPraos (EraCrypto era))
-> (TPraosToSign (EraCrypto era) -> BHBody (EraCrypto era))
-> m (TPraosFields (EraCrypto era) (BHBody (EraCrypto era)))
forall c toSign (m :: * -> *).
(PraosCrypto c, KESignable c toSign, Monad m) =>
HotKey c m
-> CanBeLeader (TPraos c)
-> IsLeader (TPraos c)
-> (TPraosToSign c -> toSign)
-> m (TPraosFields c toSign)
forgeTPraosFields HotKey (EraCrypto era) m
hotKey CanBeLeader (TPraos (EraCrypto era))
TPraosCanBeLeader (EraCrypto era)
canBeLeader IsLeader (TPraos (EraCrypto era))
TPraosIsLeader (EraCrypto era)
isLeader TPraosToSign (EraCrypto era) -> BHBody (EraCrypto era)
mkBhBody
let blk :: ShelleyBlock era
blk = Block era -> ShelleyBlock era
forall era. ShelleyBasedEra era => Block era -> ShelleyBlock era
mkShelleyBlock (Block era -> ShelleyBlock era) -> Block era -> ShelleyBlock era
forall a b. (a -> b) -> a -> b
$ BHeader (EraCrypto era) -> TxSeq era -> Block era
forall era.
Era era =>
BHeader (Crypto era) -> TxSeq era -> Block era
SL.Block (TPraosFields (EraCrypto era) (BHBody (EraCrypto era))
-> BHeader (EraCrypto era)
forall crypto c.
(Crypto crypto, KES c ~ KES crypto) =>
TPraosFields c (BHBody crypto) -> BHeader crypto
mkHeader TPraosFields (EraCrypto era) (BHBody (EraCrypto era))
tpraosFields) TxSeq era
body
ShelleyBlock era -> m (ShelleyBlock era)
forall (m :: * -> *) a. Monad m => a -> m a
return (ShelleyBlock era -> m (ShelleyBlock era))
-> ShelleyBlock era -> m (ShelleyBlock era)
forall a b. (a -> b) -> a -> b
$
Bool -> ShelleyBlock era -> ShelleyBlock era
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Word64 -> ShelleyBlock era -> Bool
forall era.
ShelleyBasedEra era =>
Word64 -> ShelleyBlock era -> Bool
verifyBlockIntegrity Word64
tpraosSlotsPerKESPeriod ShelleyBlock era
blk) (ShelleyBlock era -> ShelleyBlock era)
-> ShelleyBlock era -> ShelleyBlock era
forall a b. (a -> b) -> a -> b
$
Either String () -> ShelleyBlock era -> ShelleyBlock era
forall a. (?callStack::CallStack) => Either String () -> a -> a
assertWithMsg Either String ()
bodySizeEstimate (ShelleyBlock era -> ShelleyBlock era)
-> ShelleyBlock era -> ShelleyBlock era
forall a b. (a -> b) -> a -> b
$
ShelleyBlock era
blk
where
TPraosConfig { tpraosParams = TPraosParams { tpraosSlotsPerKESPeriod } } =
TopLevelConfig (ShelleyBlock era)
-> ConsensusConfig (BlockProtocol (ShelleyBlock era))
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig (ShelleyBlock era)
cfg
body :: TxSeq era
body = StrictSeq (Tx era) -> TxSeq era
forall era.
(Era era, TxBodyConstraints era) =>
StrictSeq (Tx era) -> TxSeq era
SL.TxSeq (StrictSeq (Tx era) -> TxSeq era)
-> StrictSeq (Tx era) -> TxSeq era
forall a b. (a -> b) -> a -> b
$ [Tx era] -> StrictSeq (Tx era)
forall a. [a] -> StrictSeq a
Seq.fromList ([Tx era] -> StrictSeq (Tx era)) -> [Tx era] -> StrictSeq (Tx era)
forall a b. (a -> b) -> a -> b
$ (\(ShelleyTx _ tx) -> Tx era
tx) (GenTx (ShelleyBlock era) -> Tx era)
-> [GenTx (ShelleyBlock era)] -> [Tx era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GenTx (ShelleyBlock era)]
txs
mkHeader :: TPraosFields c (BHBody crypto) -> BHeader crypto
mkHeader TPraosFields { SignedKES c (BHBody crypto)
tpraosSignature :: forall c toSign. TPraosFields c toSign -> SignedKES c toSign
tpraosSignature :: SignedKES c (BHBody crypto)
tpraosSignature, BHBody crypto
tpraosToSign :: forall c toSign. TPraosFields c toSign -> toSign
tpraosToSign :: BHBody crypto
tpraosToSign } =
BHBody crypto -> SignedKES crypto (BHBody crypto) -> BHeader crypto
forall crypto.
Crypto crypto =>
BHBody crypto -> SignedKES crypto (BHBody crypto) -> BHeader crypto
SL.BHeader BHBody crypto
tpraosToSign SignedKES c (BHBody crypto)
SignedKES crypto (BHBody crypto)
tpraosSignature
prevHash :: SL.PrevHash (EraCrypto era)
prevHash :: PrevHash (EraCrypto era)
prevHash =
ChainHash (Header (ShelleyBlock era)) -> PrevHash (EraCrypto era)
forall era.
ChainHash (Header (ShelleyBlock era)) -> PrevHash (EraCrypto era)
toShelleyPrevHash @era
(ChainHash (Header (ShelleyBlock era)) -> PrevHash (EraCrypto era))
-> (TickedLedgerState (ShelleyBlock era)
-> ChainHash (Header (ShelleyBlock era)))
-> TickedLedgerState (ShelleyBlock era)
-> PrevHash (EraCrypto era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainHash (TickedLedgerState (ShelleyBlock era))
-> ChainHash (Header (ShelleyBlock era))
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
ChainHash b -> ChainHash b'
castHash
(ChainHash (TickedLedgerState (ShelleyBlock era))
-> ChainHash (Header (ShelleyBlock era)))
-> (TickedLedgerState (ShelleyBlock era)
-> ChainHash (TickedLedgerState (ShelleyBlock era)))
-> TickedLedgerState (ShelleyBlock era)
-> ChainHash (Header (ShelleyBlock era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TickedLedgerState (ShelleyBlock era)
-> ChainHash (TickedLedgerState (ShelleyBlock era))
forall l. GetTip l => l -> ChainHash l
getTipHash
(TickedLedgerState (ShelleyBlock era) -> PrevHash (EraCrypto era))
-> TickedLedgerState (ShelleyBlock era) -> PrevHash (EraCrypto era)
forall a b. (a -> b) -> a -> b
$ TickedLedgerState (ShelleyBlock era)
tickedLedger
bodySizeEstimate :: Either String ()
bodySizeEstimate :: Either String ()
bodySizeEstimate
| Int
actualBodySize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
estimatedBodySize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
forall a. Num a => a
fixedBlockBodyOverhead
= String -> Either String ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
String
"Actual block body size > Estimated block body size + fixedBlockBodyOverhead: "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
actualBodySize
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" > "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
estimatedBodySize
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" + "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Int
forall a. Num a => a
fixedBlockBodyOverhead :: Int)
| Bool
otherwise
= () -> Either String ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
estimatedBodySize, actualBodySize :: Int
estimatedBodySize :: Int
estimatedBodySize = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ (Word32 -> Word32 -> Word32) -> Word32 -> [Word32] -> Word32
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
(+) Word32
0 ((GenTx (ShelleyBlock era) -> Word32)
-> [GenTx (ShelleyBlock era)] -> [Word32]
forall a b. (a -> b) -> [a] -> [b]
map GenTx (ShelleyBlock era) -> Word32
forall blk. LedgerSupportsMempool blk => GenTx blk -> Word32
txInBlockSize [GenTx (ShelleyBlock era)]
txs)
actualBodySize :: Int
actualBodySize = TxSeq era -> Int
forall era. Era era => TxSeq era -> Int
SL.bBodySize TxSeq era
body
mkBhBody :: TPraosToSign (EraCrypto era) -> BHBody (EraCrypto era)
mkBhBody TPraosToSign (EraCrypto era)
toSign = BHBody :: forall crypto.
BlockNo
-> SlotNo
-> PrevHash crypto
-> VKey 'BlockIssuer crypto
-> VerKeyVRF crypto
-> CertifiedVRF crypto Nonce
-> CertifiedVRF crypto Natural
-> Natural
-> HashBBody crypto
-> OCert crypto
-> ProtVer
-> BHBody crypto
SL.BHBody {
bheaderPrev :: PrevHash (EraCrypto era)
bheaderPrev = PrevHash (EraCrypto era)
prevHash
, bheaderVk :: VKey 'BlockIssuer (EraCrypto era)
bheaderVk = VKey 'BlockIssuer (EraCrypto era)
tpraosToSignIssuerVK
, bheaderVrfVk :: VerKeyVRF (EraCrypto era)
bheaderVrfVk = VerKeyVRF (EraCrypto era)
tpraosToSignVrfVK
, bheaderSlotNo :: SlotNo
bheaderSlotNo = SlotNo
curSlot
, bheaderBlockNo :: BlockNo
bheaderBlockNo = BlockNo
curNo
, bheaderEta :: CertifiedVRF (EraCrypto era) Nonce
bheaderEta = CertifiedVRF (EraCrypto era) Nonce
tpraosToSignEta
, bheaderL :: CertifiedVRF (EraCrypto era) Natural
bheaderL = CertifiedVRF (EraCrypto era) Natural
tpraosToSignLeader
, bsize :: Natural
bsize = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
actualBodySize
, bhash :: HashBBody (EraCrypto era)
bhash = TxSeq era -> HashBBody (EraCrypto era)
forall era. Era era => TxSeq era -> HashBBody (Crypto era)
SL.bbHash TxSeq era
body
, bheaderOCert :: OCert (EraCrypto era)
bheaderOCert = OCert (EraCrypto era)
tpraosToSignOCert
, bprotver :: ProtVer
bprotver = BlockConfig (ShelleyBlock era) -> ProtVer
forall era. BlockConfig (ShelleyBlock era) -> ProtVer
shelleyProtocolVersion (BlockConfig (ShelleyBlock era) -> ProtVer)
-> BlockConfig (ShelleyBlock era) -> ProtVer
forall a b. (a -> b) -> a -> b
$ TopLevelConfig (ShelleyBlock era) -> BlockConfig (ShelleyBlock era)
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig (ShelleyBlock era)
cfg
}
where
TPraosToSign {
VKey 'BlockIssuer (EraCrypto era)
tpraosToSignIssuerVK :: forall c. TPraosToSign c -> VKey 'BlockIssuer c
tpraosToSignIssuerVK :: VKey 'BlockIssuer (EraCrypto era)
tpraosToSignIssuerVK
, VerKeyVRF (EraCrypto era)
tpraosToSignVrfVK :: forall c. TPraosToSign c -> VerKeyVRF c
tpraosToSignVrfVK :: VerKeyVRF (EraCrypto era)
tpraosToSignVrfVK
, CertifiedVRF (EraCrypto era) Nonce
tpraosToSignEta :: forall c. TPraosToSign c -> CertifiedVRF c Nonce
tpraosToSignEta :: CertifiedVRF (EraCrypto era) Nonce
tpraosToSignEta
, CertifiedVRF (EraCrypto era) Natural
tpraosToSignLeader :: forall c. TPraosToSign c -> CertifiedVRF c Natural
tpraosToSignLeader :: CertifiedVRF (EraCrypto era) Natural
tpraosToSignLeader
, OCert (EraCrypto era)
tpraosToSignOCert :: forall c. TPraosToSign c -> OCert c
tpraosToSignOCert :: OCert (EraCrypto era)
tpraosToSignOCert
} = TPraosToSign (EraCrypto era)
toSign