{-# 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)

{-------------------------------------------------------------------------------
  Forging
-------------------------------------------------------------------------------}

forgeShelleyBlock ::
     forall m era. (ShelleyBasedEra era, Monad m)
  => HotKey (EraCrypto era) m
  -> TPraosCanBeLeader (EraCrypto era)
  -> TopLevelConfig (ShelleyBlock era)
  -> BlockNo                               -- ^ Current block number
  -> SlotNo                                -- ^ Current slot number
  -> TickedLedgerState (ShelleyBlock era)  -- ^ Current ledger
  -> [GenTx (ShelleyBlock era)]            -- ^ Txs to add in the block
  -> TPraosIsLeader (EraCrypto era)        -- ^ Leader proof
  -> 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