{-# 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 (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.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.
  SimpleCrypto c =>
  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).
SimpleCrypto c =>
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.
SimpleCrypto c =>
(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