Skip to content
Permalink
Browse files

Introduce GenTxSize

  • Loading branch information...
intricate committed Jul 12, 2019
1 parent c7045df commit 48b05e01c3dd06307802f4a981da14635c7d1dd5
@@ -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 (..))
@@ -50,7 +51,7 @@ import qualified Data.Sequence as Seq
import Data.Set (Set)
import qualified Data.Text as T
import Data.Typeable
import Data.Word (Word8)
import Data.Word (Word64, Word8)
import Formatting

import Cardano.Binary (Annotated (..), ByteSpan, fromCBOR, reAnnotate,
@@ -408,6 +409,13 @@ instance (ByronGiven, Typeable cfg, ConfigContainsGenesis cfg)

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

newtype GenTxSize (ByronBlock cfg) = ByronTxSize { unByronTxSize :: Word64 }

computeGenTxSize (ByronTx atxaux) = ByronTxSize 1337 -- Temporary placeholder value
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
@@ -247,6 +247,12 @@ instance (SimpleCrypto c, Typeable ext, SupportedBlock (SimpleBlock c ext))

computeGenTxId = SimpleGenTxId . hash . simpleGenTx

newtype GenTxSize (SimpleBlock c ext) = SimpleGenTxSize
{ simpleGenTxSize :: Word64
} deriving (Eq)

computeGenTxSize _ = SimpleGenTxSize 1337 -- Temporary placeholder value

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

applyTx = \_ -> updateSimpleLedgerState
@@ -35,6 +35,12 @@ class UpdateLedger blk => ApplyTx blk where
-- Should be cheap as this will be called often.
computeGenTxId :: GenTx blk -> GenTxId blk

-- | A serialized generalized transaction's size in bytes.
data family GenTxSize blk :: *

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

-- | 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 :: *
@@ -170,7 +176,11 @@ data Mempool m blk idx = Mempool {

-- | Get a snapshot of the current mempool state. This allows for
-- further pure queries on the snapshot.
, getSnapshot :: STM m (MempoolSnapshot (GenTxId blk) (GenTx blk) idx)
, getSnapshot :: STM m (MempoolSnapshot
(GenTxId blk)
(GenTx blk)
(GenTxSize blk)
idx)

-- | Represents the initial value at which the transaction ticket number
-- counter will start (i.e. the zeroth ticket number).
@@ -191,19 +201,21 @@ data Mempool m blk idx = Mempool {
-- even for tx sequence numbers returned in previous snapshots. This happens
-- when the transaction has been removed from the mempool between snapshots.
--
data MempoolSnapshot txid tx idx = MempoolSnapshot {
data MempoolSnapshot txid tx txsize idx = MempoolSnapshot {
-- | Get all transactions in the mempool snapshot along with their
-- associated ticket numbers (oldest to newest).
getTxs :: [(txid, tx, idx)]
-- associated post-serialization sizes (in bytes) and ticket numbers
-- (oldest to newest).
getTxs :: [(txid, tx, txsize, 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 -> [(txid, tx, idx)]
-- associated post-serialization sizes (in bytes) and ticket numbers,
-- which are associated with a ticket number greater than the one
-- provided.
, getTxsAfter :: idx -> [(txid, tx, txsize, idx)]

-- | Get a specific transaction from the mempool snapshot by its ticket
-- number, if it exists.
, getTx :: idx -> Maybe (txid, tx)
, getTx :: idx -> Maybe (txid, tx, txsize)
}

-- | Events traced by the Mempool.
@@ -160,11 +160,12 @@ implSyncState mpEnv@MempoolEnv{mpEnvTracer, mpEnvStateVar} = do
return (map fst vrInvalid, mempoolSize)
traceWith mpEnvTracer $ TraceMempoolRemoveTxs removed mempoolSize

implGetSnapshot :: ( MonadSTM m
, ApplyTx blk
)
=> MempoolEnv m blk
-> STM m (MempoolSnapshot (GenTxId blk) (GenTx blk) TicketNo)
implGetSnapshot
:: ( MonadSTM m
, ApplyTx blk
)
=> MempoolEnv m blk
-> STM m (MempoolSnapshot (GenTxId blk) (GenTx blk) (GenTxSize blk) TicketNo)
implGetSnapshot MempoolEnv{mpEnvStateVar} = do
is <- readTVar mpEnvStateVar
pure MempoolSnapshot
@@ -184,25 +185,25 @@ getMempoolSize MempoolEnv{mpEnvStateVar} =

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

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

implSnapshotGetTx :: ApplyTx blk
=> InternalState blk
-> TicketNo
-> Maybe (GenTxId blk, GenTx blk)
-> Maybe (GenTxId blk, GenTx blk, GenTxSize blk)
implSnapshotGetTx IS{isTxs} tn =
case isTxs `lookupByTicketNo` tn of
Nothing -> Nothing
Just tx -> Just (computeGenTxId tx, tx)
Just tx -> Just (computeGenTxId tx, tx, computeGenTxSize tx)

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

let txs = map sndOfTriple (getTxs mempoolSnapshot)
let txs = map sndOfQuad (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 second item in a 4-tuple.
sndOfQuad (_, b, _, _) = b

-- Return the point and block number of the most recent block in the
-- current chain with a slot < the given slot. These will either
@@ -36,7 +36,7 @@ import qualified Ouroboros.Storage.ChainDB.API as ChainDB
import qualified Ouroboros.Storage.ChainDB.Mock as Mock

import Test.Util.TestBlock (BlockChain, GenTx (..), GenTxId (..),
TestBlock, chainToBlocks, computeGenTxId,
GenTxSize (..), TestBlock, chainToBlocks, computeGenTxId,
singleNodeTestConfig, testInitExtLedger)
import Test.Util.TestTx (TestTx (..))

@@ -85,11 +85,8 @@ prop_Mempool_addTxs_getTxs bc txs =
txs
(\_ MempoolSnapshot{getTxs} ->
filter (genTxIsValid . snd) (testTxsToGenTxPairs txs)
=== dropThd getTxs)
=== map (\(a, b, _, _) -> (a, b)) 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
@@ -185,7 +182,11 @@ testAddTxsWithMempoolAndSnapshot
-> [TestTx]
-> ( forall m.
Mempool m TestBlock TicketNo
-> MempoolSnapshot (GenTxId TestBlock) (GenTx TestBlock) TicketNo
-> MempoolSnapshot
(GenTxId TestBlock)
(GenTx TestBlock)
(GenTxSize TestBlock)
TicketNo
-> prop
)
-> Property
@@ -35,6 +35,7 @@ module Test.Util.TestBlock (
-- * Mempool integration
, GenTx (..)
, GenTxId (..)
, GenTxSize (..)
, ApplyTxErr
, computeGenTxId
-- * Support for tests
@@ -297,6 +298,12 @@ instance ApplyTx TestBlock where
computeGenTxId (TestGenTx (ValidTestTx txid)) = TestGenTxId txid
computeGenTxId (TestGenTx (InvalidTestTx txid)) = TestGenTxId txid

newtype GenTxSize TestBlock = TestGenTxSize
{ testGenTxSize :: Word64
} deriving (Show, Eq)

computeGenTxSize _ = TestGenTxSize 1337 -- Temporary placeholder value

type ApplyTxErr TestBlock = TestTxError

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

0 comments on commit 48b05e0

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