Skip to content

Commit

Permalink
Merge pull request #739 from input-output-hk/mrBliss/integrate-txsubm…
Browse files Browse the repository at this point in the history
…ission-in-node

Integrate the transaction submission protocol in the Node
  • Loading branch information
mrBliss authored Jul 17, 2019
2 parents bfb41c3 + b11ee80 commit 3c1f07e
Show file tree
Hide file tree
Showing 15 changed files with 277 additions and 98 deletions.
33 changes: 20 additions & 13 deletions ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs
Original file line number Diff line number Diff line change
@@ -1,15 +1,13 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wredundant-constraints -Wno-orphans #-}

Expand All @@ -31,12 +29,14 @@ module Ouroboros.Consensus.Ledger.Byron
, encodeByronBlock
, encodeByronHeaderHash
, encodeByronGenTx
, encodeByronGenTxId
, encodeByronLedgerState
, encodeByronChainState
, decodeByronHeader
, decodeByronBlock
, decodeByronHeaderHash
, decodeByronGenTx
, decodeByronGenTxId
, decodeByronLedgerState
, decodeByronChainState
) where
Expand Down Expand Up @@ -410,7 +410,8 @@ instance (ByronGiven, Typeable cfg, ConfigContainsGenesis cfg)
-- newtype)
data GenTx (ByronBlock cfg) = ByronTx { unByronTx :: CC.UTxO.ATxAux ByteString }

data GenTxId (ByronBlock cfg) = ByronTxId { unByronTxId :: CC.UTxO.TxId }
newtype GenTxId (ByronBlock cfg) = ByronTxId { unByronTxId :: CC.UTxO.TxId }
deriving (Eq, Ord)

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

Expand Down Expand Up @@ -569,6 +570,9 @@ encodeByronHeaderHash = toCBOR
encodeByronGenTx :: GenTx (ByronBlock cfg) -> Encoding
encodeByronGenTx (ByronTx tx) = toCBOR (void tx)

encodeByronGenTxId :: GenTxId (ByronBlock cfg) -> Encoding
encodeByronGenTxId (ByronTxId txid) = toCBOR txid

encodeByronLedgerState :: LedgerState (ByronBlock cfg) -> Encoding
encodeByronLedgerState ByronLedgerState{..} = mconcat
[ encodeListLen 2
Expand Down Expand Up @@ -616,6 +620,9 @@ decodeByronGenTx =
aTaWitness = reAnnotate aTaWitness
}

decodeByronGenTxId :: Decoder s (GenTxId (ByronBlock cfg))
decodeByronGenTxId = ByronTxId <$> fromCBOR

decodeByronLedgerState :: Decoder s (LedgerState (ByronBlock cfg))
decodeByronLedgerState = do
decodeListLenOf 2
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -243,7 +243,7 @@ instance (SimpleCrypto c, Typeable ext, SupportedBlock (SimpleBlock c ext))

newtype GenTxId (SimpleBlock c ext) = SimpleGenTxId
{ simpleGenTxId :: TxId
} deriving (Eq, Ord)
} deriving (Show, Eq, Ord)

computeGenTxId = SimpleGenTxId . hash . simpleGenTx

Expand Down Expand Up @@ -336,6 +336,7 @@ instance (SimpleCrypto c, Serialise ext') => Serialise (SimpleBlock' c ext ext')
instance (SimpleCrypto c) => Serialise (SimpleStdHeader c ext)
instance Serialise SimpleBody
deriving instance Serialise (GenTx (SimpleBlock p c))
deriving instance Serialise (GenTxId (SimpleBlock p c))
instance ToCBOR SimpleBody where
toCBOR = encode
deriving instance Serialise (LedgerState (SimpleBlock c ext))
Expand Down
6 changes: 3 additions & 3 deletions ouroboros-consensus/src/Ouroboros/Consensus/Mempool/API.hs
Original file line number Diff line number Diff line change
Expand Up @@ -201,16 +201,16 @@ data Mempool m blk idx = Mempool {
data MempoolSnapshot blk idx = MempoolSnapshot {
-- | Get all transactions (oldest to newest) in the mempool snapshot along
-- with their ticket number.
getTxs :: [(GenTx blk, idx)]
snapshotTxs :: [(GenTx blk, idx)]

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

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

-- | Events traced by the Mempool.
Expand Down
6 changes: 3 additions & 3 deletions ouroboros-consensus/src/Ouroboros/Consensus/Mempool/Impl.hs
Original file line number Diff line number Diff line change
Expand Up @@ -171,9 +171,9 @@ implGetSnapshot :: ( MonadSTM m
implGetSnapshot MempoolEnv{mpEnvStateVar} = do
is <- readTVar mpEnvStateVar
pure MempoolSnapshot
{ getTxs = implSnapshotGetTxs is
, getTxsAfter = implSnapshotGetTxsAfter is
, getTx = implSnapshotGetTx is
{ snapshotTxs = implSnapshotGetTxs is
, snapshotTxsAfter = implSnapshotGetTxsAfter is
, snapshotLookupTx = implSnapshotGetTx is
}

-- | Return the number of transactions in the Mempool.
Expand Down
69 changes: 58 additions & 11 deletions ouroboros-consensus/src/Ouroboros/Consensus/Node.hs
Original file line number Diff line number Diff line change
@@ -1,13 +1,12 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

{-# OPTIONS_GHC -Wredundant-constraints -Werror=missing-fields #-}

Expand All @@ -18,6 +17,8 @@ module Ouroboros.Consensus.Node (
, NodeParams (..)
, TraceConstraints
, nodeKernel
, getMempoolReader
, getMempoolWriter
-- * Auxiliary functions
, tracePrefix
) where
Expand All @@ -26,6 +27,8 @@ import Control.Monad (void)
import Crypto.Random (ChaChaDRG)
import Data.Functor.Contravariant (contramap)
import Data.Map.Strict (Map)
import Data.Maybe (isNothing)
import Data.Word (Word16)

import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadFork (MonadFork)
Expand All @@ -39,6 +42,10 @@ import Ouroboros.Network.Block
import Ouroboros.Network.BlockFetch
import Ouroboros.Network.BlockFetch.State (FetchMode (..))
import qualified Ouroboros.Network.Chain as Chain
import Ouroboros.Network.TxSubmission.Inbound
import Ouroboros.Network.TxSubmission.Outbound hiding
(MempoolSnapshot)
import qualified Ouroboros.Network.TxSubmission.Outbound as Outbound

import Ouroboros.Consensus.Block
import Ouroboros.Consensus.BlockchainTime
Expand Down Expand Up @@ -119,6 +126,8 @@ data NodeParams m peer blk = NodeParams {
, mempoolTracer :: Tracer m (TraceEventMempool blk)
, decisionTracer :: Tracer m [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
, fetchClientTracer :: Tracer m (TraceLabelPeer peer (TraceFetchClientState (Header blk)))
, txInboundTracer :: Tracer m (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))
, txOutboundTracer :: Tracer m (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk))
, threadRegistry :: ThreadRegistry m
, maxClockSkew :: ClockSkew
, cfg :: NodeConfig (BlockProtocol blk)
Expand All @@ -128,6 +137,7 @@ data NodeParams m peer blk = NodeParams {
, callbacks :: NodeCallbacks m blk
, blockFetchSize :: Header blk -> SizeInBytes
, blockMatchesHeader :: Header blk -> blk -> Bool
, maxUnackTxs :: Word16
}

nodeKernel
Expand Down Expand Up @@ -326,7 +336,7 @@ forkBlockProduction IS{..} =
_ <- pure $ syncState mempool
mempoolSnapshot <- getSnapshot mempool

let txs = map fst (getTxs mempoolSnapshot)
let txs = map fst (snapshotTxs mempoolSnapshot)
newBlock <- runProtocol varDRG $
produceBlock
proof
Expand Down Expand Up @@ -373,3 +383,40 @@ forkBlockProduction IS{..} =
$ simChaChaT varDRG
$ id


{-------------------------------------------------------------------------------
TxSubmission integration
-------------------------------------------------------------------------------}

getMempoolReader
:: forall m blk.
(MonadSTM m, ApplyTx blk)
=> Mempool m blk TicketNo
-> TxSubmissionMempoolReader (GenTxId blk) (GenTx blk) TicketNo m
getMempoolReader mempool = TxSubmissionMempoolReader
{ mempoolZeroIdx = zeroIdx mempool
, mempoolGetSnapshot = convertSnapshot <$> getSnapshot mempool
}
where
convertSnapshot
:: MempoolSnapshot blk TicketNo
-> Outbound.MempoolSnapshot (GenTxId blk) (GenTx blk) TicketNo
convertSnapshot MempoolSnapshot{snapshotTxsAfter, snapshotLookupTx} =
Outbound.MempoolSnapshot
{ mempoolTxIdsAfter = \idx ->
[ (computeGenTxId tx, idx', txSize tx)
| (tx, idx') <- snapshotTxsAfter idx
]
, mempoolLookupTx = snapshotLookupTx
}

getMempoolWriter
:: (Monad m, ApplyTx blk)
=> Mempool m blk TicketNo
-> TxSubmissionMempoolWriter (GenTxId blk) (GenTx blk) TicketNo m
getMempoolWriter mempool = TxSubmissionMempoolWriter
{ txId = computeGenTxId
, mempoolAddTxs = \txs ->
map (computeGenTxId . fst) . filter (isNothing . snd) <$>
addTxs mempool txs
}
Original file line number Diff line number Diff line change
Expand Up @@ -47,6 +47,7 @@ class (ProtocolLedgerView blk, ApplyTx blk) => RunNode blk where
nodeEncodeBlock :: NodeConfig (BlockProtocol blk) -> blk -> Encoding
nodeEncodeHeader :: NodeConfig (BlockProtocol blk) -> Header blk -> Encoding
nodeEncodeGenTx :: GenTx blk -> Encoding
nodeEncodeGenTxId :: GenTxId blk -> Encoding
nodeEncodeHeaderHash :: Proxy blk -> HeaderHash blk -> Encoding
nodeEncodeLedgerState :: NodeConfig (BlockProtocol blk) -> LedgerState blk -> Encoding
nodeEncodeChainState :: Proxy blk -> ChainState (BlockProtocol blk) -> Encoding
Expand All @@ -56,6 +57,7 @@ class (ProtocolLedgerView blk, ApplyTx blk) => RunNode blk where
nodeDecodeHeader :: forall s. NodeConfig (BlockProtocol blk) -> Decoder s (Header blk)
nodeDecodeBlock :: forall s. NodeConfig (BlockProtocol blk) -> Decoder s blk
nodeDecodeGenTx :: forall s. Decoder s (GenTx blk)
nodeDecodeGenTxId :: forall s. Decoder s (GenTxId blk)
nodeDecodeHeaderHash :: forall s. Proxy blk -> Decoder s (HeaderHash blk)
nodeDecodeLedgerState :: forall s. NodeConfig (BlockProtocol blk) -> Decoder s (LedgerState blk)
nodeDecodeChainState :: forall s. Proxy blk -> Decoder s (ChainState (BlockProtocol blk))
2 changes: 2 additions & 0 deletions ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Byron.hs
Original file line number Diff line number Diff line change
Expand Up @@ -25,13 +25,15 @@ instance ByronGiven => RunNode (ByronBlock ByronConfig) where
nodeEncodeBlock = encodeByronBlock . pbftEpochSlots . encNodeConfigExt
nodeEncodeHeader = encodeByronHeader . pbftEpochSlots . encNodeConfigExt
nodeEncodeGenTx = encodeByronGenTx
nodeEncodeGenTxId = encodeByronGenTxId
nodeEncodeHeaderHash = const encodeByronHeaderHash
nodeEncodeLedgerState = const encodeByronLedgerState
nodeEncodeChainState = const encodeByronChainState

nodeDecodeBlock = decodeByronBlock . pbftEpochSlots . encNodeConfigExt
nodeDecodeHeader = decodeByronHeader . pbftEpochSlots . encNodeConfigExt
nodeDecodeGenTx = decodeByronGenTx
nodeDecodeGenTxId = decodeByronGenTxId
nodeDecodeHeaderHash = const decodeByronHeaderHash
nodeDecodeLedgerState = const decodeByronLedgerState
nodeDecodeChainState = const decodeByronChainState
2 changes: 2 additions & 0 deletions ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Mock.hs
Original file line number Diff line number Diff line change
Expand Up @@ -41,13 +41,15 @@ instance ( ProtocolLedgerView (SimpleBlock SimpleMockCrypto ext)
nodeEncodeBlock = const encode
nodeEncodeHeader = const encode
nodeEncodeGenTx = encode
nodeEncodeGenTxId = encode
nodeEncodeHeaderHash = const encode
nodeEncodeLedgerState = const encode
nodeEncodeChainState = const encode

nodeDecodeBlock = const decode
nodeDecodeHeader = const decode
nodeDecodeGenTx = decode
nodeDecodeGenTxId = decode
nodeDecodeHeaderHash = const decode
nodeDecodeLedgerState = const decode
nodeDecodeChainState = const decode
Loading

0 comments on commit 3c1f07e

Please sign in to comment.