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 b909978 commit c6c22f48aded8201fff44ef35acf05c4731d3b7c
@@ -41,6 +41,7 @@ import qualified Codec.CBOR.Write as CBOR
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 (..))
@@ -408,6 +409,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
@@ -1,13 +1,13 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Simple block to go with the mock ledger
--
@@ -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 c6c22f4

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