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

module Ouroboros.Consensus.Mock.Ledger.Forge
  ( ForgeExt (..)
  , forgeSimple
  ) where

import Cardano.Binary (toCBOR)
import Cardano.Crypto.Hash (hashWithSerialiser)
import Codec.Serialise (Serialise (..), serialise)
import qualified Data.ByteString.Lazy as Lazy
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.SupportsMempool (LedgerSupportsMempool (txForgetValidated))
import Ouroboros.Consensus.Mock.Ledger.Block
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Network.SizeInBytes

-- | Construct the protocol specific part of the block
--
-- This is used in 'forgeSimple', which takes care of the generic part of the
-- mock block.
--
-- Note: this is a newtype and not a type class to allow for things in the
-- closure. For example, if Praos had to use a stateful KES key, it could
-- refer to it in its closure.
newtype ForgeExt c ext = ForgeExt
  { forall c ext.
ForgeExt c ext
-> TopLevelConfig (SimpleBlock c ext)
-> IsLeader (BlockProtocol (SimpleBlock c ext))
-> SimpleBlock' c ext ()
-> SimpleBlock c ext
forgeExt ::
      TopLevelConfig (SimpleBlock c ext) ->
      IsLeader (BlockProtocol (SimpleBlock c ext)) ->
      SimpleBlock' c ext () ->
      SimpleBlock c ext
  }

forgeSimple ::
  forall c ext.
  MockProtocolSpecific c ext =>
  ForgeExt c ext ->
  ForgeBlockArgs (SimpleBlock c ext) ->
  SimpleBlock c ext
forgeSimple :: forall c ext.
MockProtocolSpecific c ext =>
ForgeExt c ext
-> ForgeBlockArgs (SimpleBlock c ext) -> SimpleBlock c ext
forgeSimple ForgeExt{TopLevelConfig (SimpleBlock c ext)
-> IsLeader (BlockProtocol (SimpleBlock c ext))
-> SimpleBlock' c ext ()
-> SimpleBlock c ext
forgeExt :: forall c ext.
ForgeExt c ext
-> TopLevelConfig (SimpleBlock c ext)
-> IsLeader (BlockProtocol (SimpleBlock c ext))
-> SimpleBlock' c ext ()
-> SimpleBlock c ext
forgeExt :: TopLevelConfig (SimpleBlock c ext)
-> IsLeader (BlockProtocol (SimpleBlock c ext))
-> SimpleBlock' c ext ()
-> SimpleBlock c ext
forgeExt} ForgeBlockArgs{[Validated (GenTx (SimpleBlock c ext))]
Maybe (PerasCert (SimpleBlock c ext))
BlockNo
SlotNo
TickedLedgerState (SimpleBlock c ext) EmptyMK
IsLeader (BlockProtocol (SimpleBlock c ext))
TopLevelConfig (SimpleBlock c ext)
fbConfig :: TopLevelConfig (SimpleBlock c ext)
fbCurrentBlockNo :: BlockNo
fbCurrentSlotNo :: SlotNo
fbPerasCert :: Maybe (PerasCert (SimpleBlock c ext))
fbCurrentTickedLedgerState :: TickedLedgerState (SimpleBlock c ext) EmptyMK
fbTxs :: [Validated (GenTx (SimpleBlock c ext))]
fbIsLeader :: IsLeader (BlockProtocol (SimpleBlock c ext))
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
fbIsLeader :: forall blk. ForgeBlockArgs blk -> IsLeader (BlockProtocol blk)
fbPerasCert :: forall blk. ForgeBlockArgs blk -> Maybe (PerasCert blk)
fbTxs :: forall blk. ForgeBlockArgs blk -> [Validated (GenTx blk)]
..} =
  TopLevelConfig (SimpleBlock c ext)
-> IsLeader (BlockProtocol (SimpleBlock c ext))
-> SimpleBlock' c ext ()
-> SimpleBlock c ext
forgeExt TopLevelConfig (SimpleBlock c ext)
fbConfig IsLeader (BlockProtocol (SimpleBlock c ext))
fbIsLeader (SimpleBlock' c ext () -> SimpleBlock c ext)
-> SimpleBlock' c ext () -> SimpleBlock c ext
forall a b. (a -> b) -> a -> b
$
    SimpleBlock
      { simpleHeader :: Header (SimpleBlock' c ext ())
simpleHeader = (() -> Encoding)
-> SimpleStdHeader c ext -> () -> Header (SimpleBlock' c ext ())
forall c ext ext'.
(HashAlgorithm (SimpleHash c), Typeable c, Typeable ext) =>
(ext' -> Encoding)
-> SimpleStdHeader c ext
-> ext'
-> Header (SimpleBlock' c ext ext')
mkSimpleHeader () -> Encoding
forall a. Serialise a => a -> Encoding
encode SimpleStdHeader c ext
stdHeader ()
      , simpleBody :: SimpleBody
simpleBody = SimpleBody
body
      }
 where
  body :: SimpleBody
  body :: SimpleBody
body = SimpleBody{simpleTxs :: [Tx]
simpleTxs = (GenTx (SimpleBlock c ext) -> Tx
forall c ext. GenTx (SimpleBlock c ext) -> Tx
simpleGenTx (GenTx (SimpleBlock c ext) -> Tx)
-> (Validated (GenTx (SimpleBlock c ext))
    -> GenTx (SimpleBlock c ext))
-> Validated (GenTx (SimpleBlock c ext))
-> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (GenTx (SimpleBlock c ext)) -> GenTx (SimpleBlock c ext)
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated) (Validated (GenTx (SimpleBlock c ext)) -> Tx)
-> [Validated (GenTx (SimpleBlock c ext))] -> [Tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Validated (GenTx (SimpleBlock c ext))]
fbTxs}

  stdHeader :: SimpleStdHeader c ext
  stdHeader :: SimpleStdHeader c ext
stdHeader =
    SimpleStdHeader
      { simplePrev :: ChainHash (SimpleBlock c ext)
simplePrev = ChainHash (Ticked LedgerState (SimpleBlock c ext))
-> ChainHash (SimpleBlock c ext)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
ChainHash b -> ChainHash b'
castHash (ChainHash (Ticked LedgerState (SimpleBlock c ext))
 -> ChainHash (SimpleBlock c ext))
-> ChainHash (Ticked LedgerState (SimpleBlock c ext))
-> ChainHash (SimpleBlock c ext)
forall a b. (a -> b) -> a -> b
$ TickedLedgerState (SimpleBlock c ext) EmptyMK
-> ChainHash (Ticked LedgerState (SimpleBlock c ext))
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> ChainHash l
getTipHash TickedLedgerState (SimpleBlock c ext) EmptyMK
fbCurrentTickedLedgerState
      , simpleSlotNo :: SlotNo
simpleSlotNo = SlotNo
fbCurrentSlotNo
      , simpleBlockNo :: BlockNo
simpleBlockNo = BlockNo
fbCurrentBlockNo
      , simpleBodyHash :: Hash (SimpleHash c) SimpleBody
simpleBodyHash = (SimpleBody -> Encoding)
-> SimpleBody -> Hash (SimpleHash c) SimpleBody
forall h a. HashAlgorithm h => (a -> Encoding) -> a -> Hash h a
hashWithSerialiser SimpleBody -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR SimpleBody
body
      , simpleBodySize :: SizeInBytes
simpleBodySize = SizeInBytes
bodySize
      }

  bodySize :: SizeInBytes
  bodySize :: SizeInBytes
bodySize = Word32 -> SizeInBytes
SizeInBytes (Word32 -> SizeInBytes) -> Word32 -> SizeInBytes
forall a b. (a -> b) -> a -> b
$ Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word32) -> Int64 -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
Lazy.length (ByteString -> Int64) -> ByteString -> Int64
forall a b. (a -> b) -> a -> b
$ SimpleBody -> ByteString
forall a. Serialise a => a -> ByteString
serialise SimpleBody
body