{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Ouroboros.Consensus.Shelley.Ledger.Forge
  ( ebTxBytes
  , forgeShelleyBlock
  ) where

import Cardano.Ledger.Binary (serialize')
import Cardano.Ledger.Block (EbReferencesAnnouncement (..))
import qualified Cardano.Ledger.Core as Core (EraTx, TopTx, Tx)
import qualified Cardano.Ledger.Core as SL
  ( blockBodySize
  , eraProtVerLow
  , hashBlockBody
  , mkBasicBlockBody
  , txSeqBlockBodyL
  )
import Cardano.Ledger.Hashes (unsafeMakeSafeHash)
import qualified Cardano.Ledger.Shelley.API as SL (Block (..), extractValidatedTx)
import qualified Cardano.Protocol.TPraos.BlockHeader as SL
import Control.Exception
import Data.ByteString (ByteString)
import Data.Foldable (asum)
import Data.List.NonEmpty (nonEmpty)
import Data.Maybe.Strict (maybeToStrictMaybe)
import qualified Data.Sequence.Strict as Seq
import Lens.Micro ((&), (.~))
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.SupportsMempool
import Ouroboros.Consensus.Leios.Types
  ( EndorserBlock
  , encodeEndorserBlockSize
  , endorserBlockFromTxBytes
  , endorserBlockHash
  )
import Ouroboros.Consensus.Protocol.Abstract (CanBeLeader)
import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey)
import Ouroboros.Consensus.Protocol.Praos.Common (WhenLeios, pureLeiosOnly)
import Ouroboros.Consensus.Shelley.Ledger.Block
import Ouroboros.Consensus.Shelley.Ledger.Config
  ( shelleyProtocolVersion
  )
import Ouroboros.Consensus.Shelley.Ledger.Integrity
import Ouroboros.Consensus.Shelley.Ledger.Mempool
import Ouroboros.Consensus.Shelley.Protocol.Abstract
  ( ProtoCrypto
  , ProtocolHeaderSupportsKES (configSlotsPerKESPeriod)
  , mkHeader
  )

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

forgeShelleyBlock ::
  forall m era proto.
  ( ShelleyCompatible proto era
  , Applicative (WhenLeios proto)
  , Foldable (WhenLeios proto)
  , Monad m
  ) =>
  HotKey (ProtoCrypto proto) m ->
  CanBeLeader proto ->
  ForgeBlockArgs (ShelleyBlock proto era) ->
  m (ForgeBlockResult (ShelleyBlock proto era))
forgeShelleyBlock :: forall (m :: * -> *) era proto.
(ShelleyCompatible proto era, Applicative (WhenLeios proto),
 Foldable (WhenLeios proto), Monad m) =>
HotKey (ProtoCrypto proto) m
-> CanBeLeader proto
-> ForgeBlockArgs (ShelleyBlock proto era)
-> m (ForgeBlockResult (ShelleyBlock proto era))
forgeShelleyBlock
  HotKey (ProtoCrypto proto) m
hotKey
  CanBeLeader proto
cbl
  ForgeBlockArgs{[Validated (GenTx (ShelleyBlock proto era))]
Maybe (PerasCert (ShelleyBlock proto era))
BlockNo
SlotNo
TickedLedgerState (ShelleyBlock proto era) EmptyMK
IsLeader (BlockProtocol (ShelleyBlock proto era))
TopLevelConfig (ShelleyBlock proto era)
fbConfig :: TopLevelConfig (ShelleyBlock proto era)
fbCurrentBlockNo :: BlockNo
fbCurrentSlotNo :: SlotNo
fbPerasCert :: Maybe (PerasCert (ShelleyBlock proto era))
fbCurrentTickedLedgerState :: TickedLedgerState (ShelleyBlock proto era) EmptyMK
fbTxs :: [Validated (GenTx (ShelleyBlock proto era))]
fbEbTxs :: [Validated (GenTx (ShelleyBlock proto era))]
fbIsLeader :: IsLeader (BlockProtocol (ShelleyBlock proto era))
fbConfig :: forall blk. ForgeBlockArgs blk -> TopLevelConfig blk
fbCurrentBlockNo :: forall blk. ForgeBlockArgs blk -> BlockNo
fbCurrentSlotNo :: forall blk. ForgeBlockArgs blk -> SlotNo
fbCurrentTickedLedgerState :: forall blk. ForgeBlockArgs blk -> TickedLedgerState blk EmptyMK
fbEbTxs :: forall blk. ForgeBlockArgs blk -> [Validated (GenTx blk)]
fbIsLeader :: forall blk. ForgeBlockArgs blk -> IsLeader (BlockProtocol blk)
fbPerasCert :: forall blk. ForgeBlockArgs blk -> Maybe (PerasCert blk)
fbTxs :: forall blk. ForgeBlockArgs blk -> [Validated (GenTx blk)]
..} =
    do
      hdr <-
        forall proto crypto (m :: * -> *) era (proxy :: * -> *).
(ProtocolHeaderSupportsKES proto, Crypto crypto, Monad m,
 crypto ~ ProtoCrypto proto, Era era) =>
proxy era
-> HotKey crypto m
-> CanBeLeader proto
-> IsLeader proto
-> SlotNo
-> BlockNo
-> PrevHash
-> Hash HASH EraIndependentBlockBody
-> Int
-> ProtVer
-> WhenLeios proto (Bool, StrictMaybe EbReferencesAnnouncement)
-> m (ShelleyProtocolHeader proto)
mkHeader @_ @(ProtoCrypto proto)
          (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @era)
          HotKey (ProtoCrypto proto) m
hotKey
          CanBeLeader proto
cbl
          IsLeader proto
IsLeader (BlockProtocol (ShelleyBlock proto era))
fbIsLeader
          SlotNo
fbCurrentSlotNo
          BlockNo
fbCurrentBlockNo
          PrevHash
prevHash
          (forall era.
EraBlockBody era =>
BlockBody era -> Hash HASH EraIndependentBlockBody
SL.hashBlockBody @era BlockBody era
body)
          Int
actualBodySize
          ProtVer
protocolVersion
          WhenLeios proto (Bool, StrictMaybe EbReferencesAnnouncement)
leiosFields
      let blk = Block (ShelleyProtocolHeader proto) era -> ShelleyBlock proto era
forall proto era.
ShelleyCompatible proto era =>
Block (ShelleyProtocolHeader proto) era -> ShelleyBlock proto era
mkShelleyBlock (Block (ShelleyProtocolHeader proto) era -> ShelleyBlock proto era)
-> Block (ShelleyProtocolHeader proto) era
-> ShelleyBlock proto era
forall a b. (a -> b) -> a -> b
$ ShelleyProtocolHeader proto
-> BlockBody era -> Block (ShelleyProtocolHeader proto) era
forall h era. h -> BlockBody era -> Block h era
SL.Block ShelleyProtocolHeader proto
hdr BlockBody era
body
      return
        ForgeBlockResult
          { rankingBlock =
              assert (verifyBlockIntegrity (configSlotsPerKESPeriod $ configConsensus fbConfig) blk) blk
          , endorserBlock = asum forgedEb
          }
   where
    protocolVersion :: ProtVer
protocolVersion = BlockConfig (ShelleyBlock proto era) -> ProtVer
forall proto era. BlockConfig (ShelleyBlock proto era) -> ProtVer
shelleyProtocolVersion (BlockConfig (ShelleyBlock proto era) -> ProtVer)
-> BlockConfig (ShelleyBlock proto era) -> ProtVer
forall a b. (a -> b) -> a -> b
$ TopLevelConfig (ShelleyBlock proto era)
-> BlockConfig (ShelleyBlock proto era)
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig (ShelleyBlock proto era)
fbConfig

    -- Only a protocol with Leios has a value in 'WhenLeios', so the other
    -- protocols build no endorser block. CIP-0164 does not allow an empty
    -- endorser block.
    forgedEb :: WhenLeios proto (Maybe EndorserBlock)
    forgedEb :: LeiosOnly proto () (Maybe EndorserBlock)
forgedEb =
      forall proto b.
Applicative (WhenLeios proto) =>
b -> WhenLeios proto b
pureLeiosOnly @proto (Maybe EndorserBlock -> LeiosOnly proto () (Maybe EndorserBlock))
-> Maybe EndorserBlock -> LeiosOnly proto () (Maybe EndorserBlock)
forall a b. (a -> b) -> a -> b
$
        NonEmpty ByteString -> EndorserBlock
endorserBlockFromTxBytes (NonEmpty ByteString -> EndorserBlock)
-> (NonEmpty (Validated (GenTx (ShelleyBlock proto era)))
    -> NonEmpty ByteString)
-> NonEmpty (Validated (GenTx (ShelleyBlock proto era)))
-> EndorserBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Validated (GenTx (ShelleyBlock proto era)) -> ByteString)
-> NonEmpty (Validated (GenTx (ShelleyBlock proto era)))
-> NonEmpty ByteString
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Tx TopTx era -> ByteString
forall era. EraTx era => Tx TopTx era -> ByteString
ebTxBytes (Tx TopTx era -> ByteString)
-> (Validated (GenTx (ShelleyBlock proto era)) -> Tx TopTx era)
-> Validated (GenTx (ShelleyBlock proto era))
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (GenTx (ShelleyBlock proto era)) -> Tx TopTx era
extractTx) (NonEmpty (Validated (GenTx (ShelleyBlock proto era)))
 -> EndorserBlock)
-> Maybe (NonEmpty (Validated (GenTx (ShelleyBlock proto era))))
-> Maybe EndorserBlock
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Validated (GenTx (ShelleyBlock proto era))]
-> Maybe (NonEmpty (Validated (GenTx (ShelleyBlock proto era))))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Validated (GenTx (ShelleyBlock proto era))]
fbEbTxs

    -- TODO Forging does not yet certify endorser blocks.
    leiosFields :: WhenLeios proto (Bool, StrictMaybe EbReferencesAnnouncement)
leiosFields = (,) Bool
False (StrictMaybe EbReferencesAnnouncement
 -> (Bool, StrictMaybe EbReferencesAnnouncement))
-> (Maybe EndorserBlock -> StrictMaybe EbReferencesAnnouncement)
-> Maybe EndorserBlock
-> (Bool, StrictMaybe EbReferencesAnnouncement)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe EbReferencesAnnouncement
-> StrictMaybe EbReferencesAnnouncement
forall a. Maybe a -> StrictMaybe a
maybeToStrictMaybe (Maybe EbReferencesAnnouncement
 -> StrictMaybe EbReferencesAnnouncement)
-> (Maybe EndorserBlock -> Maybe EbReferencesAnnouncement)
-> Maybe EndorserBlock
-> StrictMaybe EbReferencesAnnouncement
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EndorserBlock -> EbReferencesAnnouncement)
-> Maybe EndorserBlock -> Maybe EbReferencesAnnouncement
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap EndorserBlock -> EbReferencesAnnouncement
announce (Maybe EndorserBlock
 -> (Bool, StrictMaybe EbReferencesAnnouncement))
-> LeiosOnly proto () (Maybe EndorserBlock)
-> WhenLeios proto (Bool, StrictMaybe EbReferencesAnnouncement)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LeiosOnly proto () (Maybe EndorserBlock)
forgedEb

    announce :: EndorserBlock -> EbReferencesAnnouncement
announce EndorserBlock
eb =
      EbReferencesAnnouncement
        { ebReferencesAnnouncementHash :: SafeHash EraIndependentEbReferences
ebReferencesAnnouncementHash = Hash HASH EraIndependentEbReferences
-> SafeHash EraIndependentEbReferences
forall i. Hash HASH i -> SafeHash i
unsafeMakeSafeHash (EndorserBlock -> Hash HASH EraIndependentEbReferences
endorserBlockHash EndorserBlock
eb)
        , ebReferencesAnnouncementSize :: Word32
ebReferencesAnnouncementSize = EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
eb
        }

    body :: BlockBody era
body =
      BlockBody era
forall era. EraBlockBody era => BlockBody era
SL.mkBasicBlockBody
        BlockBody era -> (BlockBody era -> BlockBody era) -> BlockBody era
forall a b. a -> (a -> b) -> b
& (StrictSeq (Tx TopTx era) -> Identity (StrictSeq (Tx TopTx era)))
-> BlockBody era -> Identity (BlockBody era)
forall era.
EraBlockBody era =>
Lens' (BlockBody era) (StrictSeq (Tx TopTx era))
Lens' (BlockBody era) (StrictSeq (Tx TopTx era))
SL.txSeqBlockBodyL
          ((StrictSeq (Tx TopTx era) -> Identity (StrictSeq (Tx TopTx era)))
 -> BlockBody era -> Identity (BlockBody era))
-> StrictSeq (Tx TopTx era) -> BlockBody era -> BlockBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Tx TopTx era] -> StrictSeq (Tx TopTx era)
forall a. [a] -> StrictSeq a
Seq.fromList ((Validated (GenTx (ShelleyBlock proto era)) -> Tx TopTx era)
-> [Validated (GenTx (ShelleyBlock proto era))] -> [Tx TopTx era]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Validated (GenTx (ShelleyBlock proto era)) -> Tx TopTx era
extractTx [Validated (GenTx (ShelleyBlock proto era))]
fbTxs)

    actualBodySize :: Int
actualBodySize = ProtVer -> BlockBody era -> Int
forall era. EraBlockBody era => ProtVer -> BlockBody era -> Int
SL.blockBodySize ProtVer
protocolVersion BlockBody era
body

    extractTx :: Validated (GenTx (ShelleyBlock proto era)) -> Core.Tx Core.TopTx era
    extractTx :: Validated (GenTx (ShelleyBlock proto era)) -> Tx TopTx era
extractTx (ShelleyValidatedTx TxId
_txid ValidatedTx era
vtx) = ValidatedTx era -> Tx TopTx era
forall era. EraTx era => ValidatedTx era -> Tx TopTx era
SL.extractValidatedTx ValidatedTx era
vtx

    prevHash :: SL.PrevHash
    prevHash :: PrevHash
prevHash =
      forall proto era.
ChainHash (Header (ShelleyBlock proto era)) -> PrevHash
toShelleyPrevHash @proto
        (ChainHash (Header (ShelleyBlock proto (ZonkAny 0))) -> PrevHash)
-> (TickedLedgerState (ShelleyBlock proto era) EmptyMK
    -> ChainHash (Header (ShelleyBlock proto (ZonkAny 0))))
-> TickedLedgerState (ShelleyBlock proto era) EmptyMK
-> PrevHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainHash (Ticked LedgerState (ShelleyBlock proto era))
-> ChainHash (Header (ShelleyBlock proto (ZonkAny 0)))
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
ChainHash b -> ChainHash b'
castHash
        (ChainHash (Ticked LedgerState (ShelleyBlock proto era))
 -> ChainHash (Header (ShelleyBlock proto (ZonkAny 0))))
-> (TickedLedgerState (ShelleyBlock proto era) EmptyMK
    -> ChainHash (Ticked LedgerState (ShelleyBlock proto era)))
-> TickedLedgerState (ShelleyBlock proto era) EmptyMK
-> ChainHash (Header (ShelleyBlock proto (ZonkAny 0)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TickedLedgerState (ShelleyBlock proto era) EmptyMK
-> ChainHash (Ticked LedgerState (ShelleyBlock proto era))
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
GetTip l =>
l mk -> ChainHash l
getTipHash
        (TickedLedgerState (ShelleyBlock proto era) EmptyMK -> PrevHash)
-> TickedLedgerState (ShelleyBlock proto era) EmptyMK -> PrevHash
forall a b. (a -> b) -> a -> b
$ TickedLedgerState (ShelleyBlock proto era) EmptyMK
fbCurrentTickedLedgerState

-- | The bytes of a transaction that an endorser block references.
--
-- The length of these bytes must not exceed 'txByteSizeWithOverhead'.
-- Otherwise the endorser block can exceed the size that
-- 'txEbMeasureDijkstra' reserved for it, and header validation rejects the
-- block with 'LeiosEbTooBig'.
ebTxBytes :: forall era. Core.EraTx era => Core.Tx Core.TopTx era -> ByteString
ebTxBytes :: forall era. EraTx era => Tx TopTx era -> ByteString
ebTxBytes = Version -> Tx TopTx era -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize' (forall era. Era era => Version
SL.eraProtVerLow @era)