Skip to content
Permalink
Browse files

Introduce computeGenTxSize

Co-authored-by: Thomas Winant <thomas@well-typed.com>
  • Loading branch information...
intricate and mrBliss committed Jul 12, 2019
1 parent a2eae71 commit a15e908c47921c5c2b88ed31dbc5b30c7c0c2be8
@@ -49,6 +49,7 @@ import Codec.Serialise (Serialise, decode, encode)
import Control.Monad.Except
import Control.Monad.Reader
import qualified Data.Bimap as Bimap
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
import Data.Coerce (coerce)
import Data.FingerTree (Measured (..))
@@ -416,6 +417,11 @@ instance (ByronGiven, Typeable cfg, ConfigContainsGenesis cfg)

computeGenTxId = ByronTxId . Crypto.hash . CC.UTxO.taTx . unByronTx

computeGenTxSize (ByronTx atxaux) = fromIntegral txByteSize
where
txByteSize = (Strict.length . annotation . CC.UTxO.aTaTx $ atxaux)
+ (Strict.length . annotation . CC.UTxO.aTaWitness $ atxaux)

type ApplyTxErr (ByronBlock cfg) = CC.UTxO.UTxOValidationError

applyTx = applyByronGenTx False
@@ -50,7 +50,7 @@ import Data.Typeable (Typeable)
import Data.Word
import GHC.Generics (Generic)

import Cardano.Binary (ToCBOR(..))
import Cardano.Binary (ToCBOR (..))
import Cardano.Crypto.Hash

import Ouroboros.Network.Block
@@ -247,6 +247,8 @@ instance (SimpleCrypto c, Typeable ext, SupportedBlock (SimpleBlock c ext))

computeGenTxId = SimpleGenTxId . hash . simpleGenTx

computeGenTxSize _ = 2000 -- TODO #745

type ApplyTxErr (SimpleBlock c ext) = MockError (SimpleBlock c ext)

applyTx = \_ -> updateSimpleLedgerState
@@ -9,6 +9,8 @@ module Ouroboros.Consensus.Mempool.API (
, MempoolSnapshot(..)
, ApplyTx(..)
, TraceEventMempool(..)
-- * Re-exports
, TxSizeInBytes
) where

import Control.Monad.Except
@@ -17,6 +19,8 @@ import GHC.Stack (HasCallStack)

import Control.Monad.Class.MonadSTM

import Ouroboros.Network.Protocol.TxSubmission.Type (TxSizeInBytes)

import Ouroboros.Consensus.Ledger.Abstract

class UpdateLedger blk => ApplyTx blk where
@@ -35,6 +39,9 @@ class UpdateLedger blk => ApplyTx blk where
-- Should be cheap as this will be called often.
computeGenTxId :: GenTx blk -> GenTxId blk

-- | Given a 'GenTx', compute its post-serialization size in bytes.
computeGenTxSize :: GenTx blk -> TxSizeInBytes

-- | Updating the ledger with a single transaction may result in a different
-- error type as when updating it with a block
type family ApplyTxErr blk :: *
@@ -192,14 +199,14 @@ data Mempool m blk idx = Mempool {
-- when the transaction has been removed from the mempool between snapshots.
--
data MempoolSnapshot blk idx = MempoolSnapshot {
-- | Get all transactions in the mempool snapshot along with their
-- associated ticket numbers (oldest to newest).
getTxs :: [(GenTxId blk, GenTx blk, idx)]

-- | Get all transactions in the mempool snapshot, along with their
-- associated ticket numbers, which are associated with a ticket number
-- greater than the one provided.
, getTxsAfter :: idx -> [(GenTxId blk, GenTx blk, idx)]
-- | Get all transactions (oldest to newest) in the mempool snapshot along
-- with their ticket number and size.
getTxs :: [(GenTx blk, idx, TxSizeInBytes)]

-- | Get all transactions (oldest to newest) in the mempool snapshot,
-- along with their ticket number and size, which are associated with a
-- ticket number greater than the one provided.
, getTxsAfter :: idx -> [(GenTx blk, idx, TxSizeInBytes)]

-- | Get a specific transaction from the mempool snapshot by its ticket
-- number, if it exists.
@@ -184,15 +184,15 @@ getMempoolSize MempoolEnv{mpEnvStateVar} =

implSnapshotGetTxs :: ApplyTx blk
=> InternalState blk
-> [(GenTxId blk, GenTx blk, TicketNo)]
-> [(GenTx blk, TicketNo, TxSizeInBytes)]
implSnapshotGetTxs = (flip implSnapshotGetTxsAfter) zeroTicketNo

implSnapshotGetTxsAfter :: ApplyTx blk
=> InternalState blk
-> TicketNo
-> [(GenTxId blk, GenTx blk, TicketNo)]
-> [(GenTx blk, TicketNo, TxSizeInBytes)]
implSnapshotGetTxsAfter IS{isTxs} tn = map
(\(tx, txTn) -> (computeGenTxId tx, tx, txTn))
(\(tx, txTn) -> (tx, txTn, computeGenTxSize tx))
(TxSeq.fromTxSeq $ snd $ splitAfterTicketNo isTxs tn)

implSnapshotGetTx :: ApplyTx blk
@@ -326,7 +326,7 @@ forkBlockProduction IS{..} =
_ <- pure $ syncState mempool
mempoolSnapshot <- getSnapshot mempool

let txs = map sndOfTriple (getTxs mempoolSnapshot)
let txs = map fst3 (getTxs mempoolSnapshot)
newBlock <- runProtocol varDRG $
produceBlock
proof
@@ -345,8 +345,8 @@ forkBlockProduction IS{..} =
where
NodeCallbacks{..} = callbacks

-- Return the second item in a triple.
sndOfTriple (_, b, _) = b
-- Return the first item in a 3-tuple.
fst3 (a, _, _) = a

-- Return the point and block number of the most recent block in the
-- current chain with a slot < the given slot. These will either
@@ -85,11 +85,8 @@ prop_Mempool_addTxs_getTxs bc txs =
txs
(\_ MempoolSnapshot{getTxs} ->
filter (genTxIsValid . snd) (testTxsToGenTxPairs txs)
=== dropThd getTxs)
=== map (\(tx, _, _) -> (computeGenTxId tx, tx)) getTxs)
where
dropThd :: [(a, b, c)] -> [(a, b)]
dropThd = map (\(a, b, _) -> (a, b))
--
genTxIsValid :: GenTx TestBlock -> Bool
genTxIsValid (TestGenTx (ValidTestTx _)) = True
genTxIsValid _ = False
@@ -107,7 +104,7 @@ prop_Mempool_InvalidTxsNeverAdded bc txs =
bc
txs
(\_ MempoolSnapshot{getTxs} ->
filter (\(_, tx, _) -> genTxIsInvalid tx) getTxs === [])
filter (\(tx, _, _) -> genTxIsInvalid tx) getTxs === [])
where
genTxIsInvalid :: GenTx TestBlock -> Bool
genTxIsInvalid (TestGenTx (InvalidTestTx _)) = True
@@ -297,6 +297,8 @@ instance ApplyTx TestBlock where
computeGenTxId (TestGenTx (ValidTestTx txid)) = TestGenTxId txid
computeGenTxId (TestGenTx (InvalidTestTx txid)) = TestGenTxId txid

computeGenTxSize _ = 2000 -- TODO #745

type ApplyTxErr TestBlock = TestTxError

applyTx = \_ (TestGenTx tx) st -> case tx of

0 comments on commit a15e908

Please sign in to comment.
You can’t perform that action at this time.