{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

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

import Cardano.Binary (toCBOR)
import Cardano.Crypto.Hash (HashAlgorithm, hashWithSerialiser)
import Codec.Serialise (Serialise (..), serialise)
import qualified Data.ByteString.Lazy as Lazy
import Data.Typeable (Typeable)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.Abstract
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 mk.
  (HashAlgorithm (SimpleHash c), Typeable c, Typeable ext) =>
  ForgeExt c ext ->
  TopLevelConfig (SimpleBlock c ext) ->
  -- | Current block number
  BlockNo ->
  -- | Current slot number
  SlotNo ->
  -- | Current ledger
  TickedLedgerState (SimpleBlock c ext) mk ->
  -- | Txs to include
  [GenTx (SimpleBlock c ext)] ->
  IsLeader (BlockProtocol (SimpleBlock c ext)) ->
  SimpleBlock c ext
forgeSimple :: forall c ext (mk :: MapKind).
(HashAlgorithm (SimpleHash c), Typeable c, Typeable ext) =>
ForgeExt c ext
-> TopLevelConfig (SimpleBlock c ext)
-> BlockNo
-> SlotNo
-> TickedLedgerState (SimpleBlock c ext) mk
-> [GenTx (SimpleBlock c ext)]
-> IsLeader (BlockProtocol (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} TopLevelConfig (SimpleBlock c ext)
cfg BlockNo
curBlock SlotNo
curSlot TickedLedgerState (SimpleBlock c ext) mk
tickedLedger [GenTx (SimpleBlock c ext)]
txs IsLeader (BlockProtocol (SimpleBlock c ext))
proof =
  TopLevelConfig (SimpleBlock c ext)
-> IsLeader (BlockProtocol (SimpleBlock c ext))
-> SimpleBlock' c ext ()
-> SimpleBlock c ext
forgeExt TopLevelConfig (SimpleBlock c ext)
cfg IsLeader (BlockProtocol (SimpleBlock c ext))
proof (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)
-> [GenTx (SimpleBlock c ext)] -> [Tx]
forall a b. (a -> b) -> [a] -> [b]
map GenTx (SimpleBlock c ext) -> Tx
forall c ext. GenTx (SimpleBlock c ext) -> Tx
simpleGenTx [GenTx (SimpleBlock c ext)]
txs}

  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) mk
-> ChainHash (Ticked (LedgerState (SimpleBlock c ext)))
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> ChainHash l
getTipHash TickedLedgerState (SimpleBlock c ext) mk
tickedLedger
      , simpleSlotNo :: SlotNo
simpleSlotNo = SlotNo
curSlot
      , simpleBlockNo :: BlockNo
simpleBlockNo = BlockNo
curBlock
      , 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