{-# 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
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
-> SlotNo
-> TickedLedgerState (SimpleBlock c ext)
-> [GenTx (SimpleBlock c ext)]
-> 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