{-# 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           Codec.Serialise (Serialise (..), serialise)
import qualified Data.ByteString.Lazy as Lazy
import           Data.Word

import           Cardano.Crypto.Hash (hashWithSerialiser)

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Mock.Ledger.Block
import           Ouroboros.Consensus.Protocol.Abstract

-- | 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 {
      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.
               ( SimpleCrypto c
               , MockProtocolSpecific c ext
               )
            => ForgeExt c ext
            -> TopLevelConfig (SimpleBlock c ext)
            -> BlockNo                                   -- ^ Current block number
            -> SlotNo                                    -- ^ Current slot number
            -> TickedLedgerState (SimpleBlock c ext)     -- ^ Current ledger
            -> [GenTx (SimpleBlock c ext)]               -- ^ Txs to include
            -> IsLeader (BlockProtocol (SimpleBlock c ext))
            -> SimpleBlock c ext
forgeSimple :: ForgeExt c ext
-> TopLevelConfig (SimpleBlock c ext)
-> BlockNo
-> SlotNo
-> TickedLedgerState (SimpleBlock c ext)
-> [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 :: 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)
cfg BlockNo
curBlock SlotNo
curSlot TickedLedgerState (SimpleBlock c ext)
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 :: forall c ext ext'.
Header (SimpleBlock' c ext ext')
-> SimpleBody -> SimpleBlock' c ext ext'
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 :: [Tx] -> SimpleBody
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 :: forall c ext.
ChainHash (SimpleBlock c ext)
-> SlotNo
-> BlockNo
-> Hash (SimpleHash c) SimpleBody
-> Word32
-> SimpleStdHeader c ext
SimpleStdHeader {
          simplePrev :: ChainHash (SimpleBlock c ext)
simplePrev     = ChainHash (TickedLedgerState (SimpleBlock c ext))
-> ChainHash (SimpleBlock c ext)
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
ChainHash b -> ChainHash b'
castHash (ChainHash (TickedLedgerState (SimpleBlock c ext))
 -> ChainHash (SimpleBlock c ext))
-> ChainHash (TickedLedgerState (SimpleBlock c ext))
-> ChainHash (SimpleBlock c ext)
forall a b. (a -> b) -> a -> b
$ TickedLedgerState (SimpleBlock c ext)
-> ChainHash (TickedLedgerState (SimpleBlock c ext))
forall l. GetTip l => l -> ChainHash l
getTipHash TickedLedgerState (SimpleBlock c ext)
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 :: Word32
simpleBodySize = Word32
bodySize
        }

    bodySize :: Word32
    bodySize :: Word32
bodySize = 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