From 74f05f45381adc072c1c63789299f01e3ff79684 Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Tue, 11 Oct 2022 16:47:50 +0100 Subject: [PATCH] Peer Sharing - MiniProtocol Create PeerSharing Typed Protocol and tests Add Peer Sharing CDDL spec and tests --- .../Network/PeerSelection/PeerSharing/Type.hs | 67 +++++- .../ouroboros-network-protocols.cabal | 18 +- .../Network/Protocol/PeerSharing/Client.hs | 38 ++++ .../Network/Protocol/PeerSharing/Codec.hs | 135 +++++++++++++ .../Network/Protocol/PeerSharing/Server.hs | 39 ++++ .../Network/Protocol/PeerSharing/Type.hs | 83 ++++++++ ouroboros-network-protocols/test-cddl/Main.hs | 63 +++++- .../test-cddl/specs/peer-sharing.cddl | 22 ++ .../Network/Protocol/PeerSharing/Direct.hs | 18 ++ .../Network/Protocol/PeerSharing/Examples.hs | 40 ++++ .../Network/Protocol/PeerSharing/Test.hs | 191 ++++++++++++++++++ ouroboros-network/ouroboros-network.cabal | 3 +- .../src/Ouroboros/Network/NodeToNode.hs | 7 + .../src/Ouroboros/Network/PeerSharing.hs | 24 +++ ouroboros-network/test/Main.hs | 2 + .../test/Test/Ouroboros/Network/Orphans.hs | 1 - 16 files changed, 735 insertions(+), 16 deletions(-) create mode 100644 ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Client.hs create mode 100644 ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Codec.hs create mode 100644 ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Server.hs create mode 100644 ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Type.hs create mode 100644 ouroboros-network-protocols/test-cddl/specs/peer-sharing.cddl create mode 100644 ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Direct.hs create mode 100644 ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Examples.hs create mode 100644 ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Test.hs create mode 100644 ouroboros-network/src/Ouroboros/Network/PeerSharing.hs diff --git a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerSharing/Type.hs b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerSharing/Type.hs index 2b9dcefa98e..304c29e07f1 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerSharing/Type.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerSharing/Type.hs @@ -1,13 +1,23 @@ {-# LANGUAGE DeriveGeneric #-} +{-# OPTIONS_GHC -Wno-orphans #-} + module Ouroboros.Network.PeerSelection.PeerSharing.Type ( PeerSharing (..) , combinePeerInformation + , encodePortNumber + , decodePortNumber + , encodeRemoteAddress + , decodeRemoteAddress ) where -import Data.Aeson +import qualified Codec.CBOR.Decoding as CBOR +import qualified Codec.CBOR.Encoding as CBOR +import Data.Aeson.Types (FromJSON (..), ToJSON (..), Value (..), + withText) import qualified Data.Text as Text import GHC.Generics (Generic) +import Network.Socket (PortNumber, SockAddr (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise.Type (PeerAdvertise (..)) import Text.Read (readMaybe) @@ -50,4 +60,57 @@ combinePeerInformation :: PeerSharing -> PeerAdvertise -> PeerSharing combinePeerInformation NoPeerSharing _ = NoPeerSharing combinePeerInformation PeerSharingPrivate _ = PeerSharingPrivate combinePeerInformation PeerSharingPublic DoNotAdvertisePeer = PeerSharingPrivate -combinePeerInformation _ _ = PeerSharingPublic +combinePeerInformation _ _ = PeerSharingPublic + +encodePortNumber :: PortNumber -> CBOR.Encoding +encodePortNumber = CBOR.encodeWord16 . fromIntegral + +decodePortNumber :: CBOR.Decoder s PortNumber +decodePortNumber = fromIntegral <$> CBOR.decodeWord16 + + +-- | This encoder should be faithful to the PeerSharing +-- CDDL Specification. +-- +-- See the network design document for more details +-- +encodeRemoteAddress :: SockAddr -> CBOR.Encoding +encodeRemoteAddress (SockAddrInet pn w) = CBOR.encodeListLen 3 + <> CBOR.encodeWord 0 + <> CBOR.encodeWord32 w + <> encodePortNumber pn +encodeRemoteAddress (SockAddrInet6 pn fi (w1, w2, w3, w4) si) = CBOR.encodeListLen 8 + <> CBOR.encodeWord 1 + <> CBOR.encodeWord32 w1 + <> CBOR.encodeWord32 w2 + <> CBOR.encodeWord32 w3 + <> CBOR.encodeWord32 w4 + <> CBOR.encodeWord32 fi + <> CBOR.encodeWord32 si + <> encodePortNumber pn +encodeRemoteAddress (SockAddrUnix _) = error "Should never be encoding a SockAddrUnix!" + +-- | This decoder should be faithful to the PeerSharing +-- CDDL Specification. +-- +-- See the network design document for more details +-- +decodeRemoteAddress :: CBOR.Decoder s SockAddr +decodeRemoteAddress = do + _ <- CBOR.decodeListLen + tok <- CBOR.decodeWord + case tok of + 0 -> do + w <- CBOR.decodeWord32 + pn <- decodePortNumber + return (SockAddrInet pn w) + 1 -> do + w1 <- CBOR.decodeWord32 + w2 <- CBOR.decodeWord32 + w3 <- CBOR.decodeWord32 + w4 <- CBOR.decodeWord32 + fi <- CBOR.decodeWord32 + si <- CBOR.decodeWord32 + pn <- decodePortNumber + return (SockAddrInet6 pn fi (w1, w2, w3, w4) si) + _ -> fail ("Serialise.decode.SockAddr unexpected tok " ++ show tok) diff --git a/ouroboros-network-protocols/ouroboros-network-protocols.cabal b/ouroboros-network-protocols/ouroboros-network-protocols.cabal index fbf0d6c1a41..25e8553c6fd 100644 --- a/ouroboros-network-protocols/ouroboros-network-protocols.cabal +++ b/ouroboros-network-protocols/ouroboros-network-protocols.cabal @@ -65,6 +65,10 @@ library Ouroboros.Network.Protocol.KeepAlive.Client Ouroboros.Network.Protocol.KeepAlive.Server Ouroboros.Network.Protocol.KeepAlive.Codec + Ouroboros.Network.Protocol.PeerSharing.Type + Ouroboros.Network.Protocol.PeerSharing.Client + Ouroboros.Network.Protocol.PeerSharing.Server + Ouroboros.Network.Protocol.PeerSharing.Codec default-language: Haskell2010 other-extensions: BangPatterns, @@ -94,10 +98,10 @@ library bytestring >=0.10 && <0.12, cborg >=0.2.1 && <0.3, - io-classes, - ouroboros-network-api - ^>=0.1, - typed-protocols, + io-classes ^>=0.3, + ouroboros-network-api, + serialise, + typed-protocols >=0.1 && <1.0, typed-protocols-cborg >=0.1 && <1.0 @@ -143,6 +147,9 @@ library testlib Ouroboros.Network.Protocol.KeepAlive.Direct Ouroboros.Network.Protocol.KeepAlive.Examples Ouroboros.Network.Protocol.KeepAlive.Test + Ouroboros.Network.Protocol.PeerSharing.Direct + Ouroboros.Network.Protocol.PeerSharing.Examples + Ouroboros.Network.Protocol.PeerSharing.Test Test.ChainGenerators Test.ChainProducerState @@ -196,7 +203,7 @@ test-suite test ghc-options: -Wall -Wunused-packages - + test-suite cddl type: exitcode-stdio-1.0 hs-source-dirs: test-cddl @@ -217,6 +224,7 @@ test-suite cddl serialise, text, temporary, + network, QuickCheck, quickcheck-instances, diff --git a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Client.hs b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Client.hs new file mode 100644 index 00000000000..5cb4169d210 --- /dev/null +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Client.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + +module Ouroboros.Network.Protocol.PeerSharing.Client where + +import Network.TypedProtocol.Core (Peer (..), PeerHasAgency (..), + PeerRole (..)) +import Ouroboros.Network.Protocol.PeerSharing.Type + (ClientHasAgency (..), Message (..), NobodyHasAgency (..), + PeerSharing (..), PeerSharingAmount, ServerHasAgency (..)) + +data PeerSharingClient peerAddress m a where + SendMsgShareRequest + :: PeerSharingAmount + -> ([peerAddress] -> m (PeerSharingClient peerAddress m a)) + -> PeerSharingClient peerAddress m a + + SendMsgDone + :: m a -> PeerSharingClient peerAddress m a + +-- | Interpret a particular client action sequence into the client side of the +-- 'PeerSharing' protocol. +-- +peerSharingClientPeer :: Monad m + => PeerSharingClient peerAddress m a + -> Peer (PeerSharing peerAddress) AsClient StIdle m a +peerSharingClientPeer (SendMsgShareRequest amount k) = + -- Send MsgShareRequest message + Yield (ClientAgency TokIdle) (MsgShareRequest amount) $ + -- Wait for the reply (notice the agency proofs) + Await (ServerAgency TokBusy) $ \(MsgSharePeers resp) -> + -- We have our reply. We might want to perform some action with it so we + -- run the continuation to handle t he response. + Effect $ peerSharingClientPeer <$> k resp +peerSharingClientPeer (SendMsgDone result) = + -- Perform some finishing action + -- Perform a transition to the 'StDone' state + Effect $ (Yield (ClientAgency TokIdle) MsgDone . Done TokDone) <$> result diff --git a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Codec.hs b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Codec.hs new file mode 100644 index 00000000000..c83a90dedb3 --- /dev/null +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Codec.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Network.Protocol.PeerSharing.Codec where + +import Control.Monad.Class.MonadST + +import Data.ByteString.Lazy (ByteString) + +import qualified Codec.CBOR.Read as CBOR + +import Network.TypedProtocol.Codec.CBOR + +import qualified Codec.CBOR.Decoding as CBOR +import qualified Codec.CBOR.Encoding as CBOR +import qualified Codec.Serialise.Class as CBOR +import Ouroboros.Network.Protocol.PeerSharing.Type + (ClientHasAgency (..), Message (..), PeerSharing, + ServerHasAgency (..)) + +import Control.Monad.Class.MonadTime (DiffTime) +import Ouroboros.Network.Protocol.Limits + +codecPeerSharing :: forall m peerAddress. + MonadST m + => (peerAddress -> CBOR.Encoding) + -> (forall s . CBOR.Decoder s peerAddress) + -> Codec (PeerSharing peerAddress) + CBOR.DeserialiseFailure + m + ByteString +codecPeerSharing encodeAddress decodeAddress = mkCodecCborLazyBS encodeMsg decodeMsg + where + encodeMsg :: PeerHasAgency pr st + -> Message (PeerSharing peerAddress) st st' + -> CBOR.Encoding + encodeMsg (ClientAgency TokIdle) (MsgShareRequest amount) = + CBOR.encodeListLen 2 + <> CBOR.encodeWord 0 + <> CBOR.encode amount + encodeMsg (ServerAgency TokBusy) (MsgSharePeers peers) = + CBOR.encodeListLen 2 + <> CBOR.encodeWord 1 + <> encodeListWith encodeAddress peers + encodeMsg (ClientAgency TokIdle) MsgDone = + CBOR.encodeListLen 1 + <> CBOR.encodeWord 2 + + decodeMsg :: PeerHasAgency pr (st :: PeerSharing peerAddress) + -> CBOR.Decoder s (SomeMessage st) + decodeMsg stok = do + _ <- CBOR.decodeListLen + key <- CBOR.decodeWord + case (stok, key) of + (ClientAgency TokIdle, 0) -> SomeMessage . MsgShareRequest + <$> CBOR.decode + (ServerAgency TokBusy, 1) -> SomeMessage . MsgSharePeers + <$> decodeListWith decodeAddress + (ClientAgency TokIdle, 2) -> return + $ SomeMessage MsgDone + + (ClientAgency TokIdle, _) -> + fail ("codecPeerSharing.StIdle: unexpected key: " ++ show key) + (ServerAgency TokBusy, _) -> + fail ("codecPeerSharing.StBusy: unexpected key: " ++ show key) + + -- Definition as in CBOR.encodeList but indexed by an external encoder + encodeListWith :: (a -> CBOR.Encoding) -> [a] -> CBOR.Encoding + encodeListWith _ [] = CBOR.encodeListLen 0 + encodeListWith enc xs = CBOR.encodeListLenIndef + <> foldr (\x r -> enc x <> r) CBOR.encodeBreak xs + -- Definition as in Cardano.Binary.FromCBOR.encodeList to avoid Serialise + -- dependency + decodeListWith :: CBOR.Decoder s a -> CBOR.Decoder s [a] + decodeListWith d = do + CBOR.decodeListLenIndef + CBOR.decodeSequenceLenIndef (flip (:)) [] reverse d + + +codecPeerSharingId + :: forall peerAddress m. + Monad m + => Codec (PeerSharing peerAddress) CodecFailure m (AnyMessage (PeerSharing peerAddress)) +codecPeerSharingId = Codec encodeMsg decodeMsg + where + encodeMsg :: forall (pr :: PeerRole) st st'. + PeerHasAgency pr st + -> Message (PeerSharing peerAddress) st st' + -> AnyMessage (PeerSharing peerAddress) + encodeMsg _ = AnyMessage + + decodeMsg :: forall (pr :: PeerRole) (st :: (PeerSharing peerAddress)). + PeerHasAgency pr st + -> m (DecodeStep (AnyMessage (PeerSharing peerAddress)) + CodecFailure m (SomeMessage st)) + decodeMsg stok = return $ DecodePartial $ \bytes -> return $ + case (stok, bytes) of + (ClientAgency TokIdle, Just (AnyMessage msg@(MsgShareRequest {}))) + -> DecodeDone (SomeMessage msg) Nothing + (ServerAgency TokBusy, Just (AnyMessage msg@(MsgSharePeers {}))) + -> DecodeDone (SomeMessage msg) Nothing + (ClientAgency TokIdle, Just (AnyMessage msg@(MsgDone))) + -> DecodeDone (SomeMessage msg) Nothing + (_, _) -> DecodeFail (CodecFailure "codecPeerSharingId: no matching message") + +-- | We assume that a TCP segment size of 1440 bytes with initial window of size +-- 4. This sets upper limit of 5760 bytes on each message of peer sharing +-- protocol, which means request and response should be done in a single RTT +-- +maxTransmissionUnit :: Word +maxTransmissionUnit = 4 * 1440 + +byteLimitsPeerSharing :: (bytes -> Word) + -> ProtocolSizeLimits (PeerSharing peerAddress) bytes +byteLimitsPeerSharing = ProtocolSizeLimits sizeLimitForState + where + sizeLimitForState :: PeerHasAgency (pr :: PeerRole) + (st :: PeerSharing peerAddress) + -> Word + sizeLimitForState (ClientAgency TokIdle) = maxTransmissionUnit + sizeLimitForState (ServerAgency TokBusy) = maxTransmissionUnit + + +timeLimitsPeerSharing :: ProtocolTimeLimits (PeerSharing peerAddress) +timeLimitsPeerSharing = ProtocolTimeLimits { timeLimitForState } + where + timeLimitForState :: PeerHasAgency (pr :: PeerRole) + (st :: PeerSharing peerAddress) + -> Maybe DiffTime + timeLimitForState (ClientAgency TokIdle) = waitForever + timeLimitForState (ServerAgency TokBusy) = longWait diff --git a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Server.hs b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Server.hs new file mode 100644 index 00000000000..14d34eaac96 --- /dev/null +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Server.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} + +module Ouroboros.Network.Protocol.PeerSharing.Server where + +import Network.TypedProtocol.Core (Peer (..), PeerHasAgency (..), + PeerRole (..)) +import Ouroboros.Network.Protocol.PeerSharing.Type + (ClientHasAgency (..), Message (..), NobodyHasAgency (..), + PeerSharing (..), PeerSharingAmount, ServerHasAgency (..)) + +data PeerSharingServer peerAddress m = PeerSharingServer { + -- | The client sent us a 'MsgShareRequest'. We have need to compute the + -- response. + -- + recvMsgShareRequest :: PeerSharingAmount + -> m ( [peerAddress] + , PeerSharingServer peerAddress m + ) + } + +peerSharingServerPeer :: Monad m + => PeerSharingServer peerAddress m + -> Peer (PeerSharing peerAddress) AsServer StIdle m () +peerSharingServerPeer PeerSharingServer{..} = + -- Await receival of a message from the client + Await (ClientAgency TokIdle) $ \msg -> + -- Can be either 'MsgShareRequest' or 'MsgDone' + case msg of + -- Compute the response and send 'MsgSharePeers' message + MsgShareRequest amount -> Effect $ do + (resp, server) <- recvMsgShareRequest amount + return $ + Yield (ServerAgency TokBusy) + (MsgSharePeers resp) + (peerSharingServerPeer server) + -- Nothing to do. + MsgDone -> Done TokDone () diff --git a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Type.hs b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Type.hs new file mode 100644 index 00000000000..3a3b620ed65 --- /dev/null +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Type.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Ouroboros.Network.Protocol.PeerSharing.Type where + +import Codec.Serialise.Class (Serialise) +import Data.Word (Word8) +import GHC.Generics (Generic) +import Network.TypedProtocol.Core (Protocol (..)) +import Ouroboros.Network.Util.ShowProxy (ShowProxy (..)) + +-- | PeerSharing amount new type. +-- +-- We use 'Word8' to be faithful to the CDDL specification. +newtype PeerSharingAmount = PeerSharingAmount { getAmount :: Word8 } + deriving (Eq, Show, Ord, Generic) + deriving (Enum, Num, Real, Integral, Serialise) via Word8 + +-- | A kind to identify our protocol, and the types of the states in the state +-- transition diagram of the protocol. +-- +data PeerSharing peerAddress where + + -- | The client can send a request and the server is waiting for a request. + -- + StIdle :: PeerSharing peerAddress + + -- | The server is responsible for sending response back. + -- + StBusy :: PeerSharing peerAddress + + -- | Both the client and server are in the terminal state. They're done. + -- + StDone :: PeerSharing peerAddress + +instance ShowProxy (PeerSharing peer) where + showProxy _ = "PeerSharing" + +instance Protocol (PeerSharing peerAddress) where + data Message (PeerSharing peerAddress) from to where + MsgShareRequest :: PeerSharingAmount + -> Message (PeerSharing peerAddress) StIdle StBusy + MsgSharePeers :: [peerAddress] + -> Message (PeerSharing peerAddress) StBusy StIdle + MsgDone :: Message (PeerSharing peerAddress) StIdle StDone + + data ClientHasAgency st where + TokIdle :: ClientHasAgency StIdle + + data ServerHasAgency st where + TokBusy :: ServerHasAgency StBusy + + data NobodyHasAgency st where + TokDone :: NobodyHasAgency StDone + + exclusionLemma_ClientAndServerHaveAgency TokIdle tok = case tok of {} + exclusionLemma_NobodyAndClientHaveAgency TokDone tok = case tok of {} + exclusionLemma_NobodyAndServerHaveAgency TokDone tok = case tok of {} + +instance Show peer => Show (Message (PeerSharing peer) from to) where + show (MsgShareRequest amount) = "MsgShareRequest " ++ show amount + show (MsgSharePeers resp) = "MsgSharePeers " ++ show resp + show MsgDone = "MsgDone" + +deriving instance (Show peerAddress) => Show (PeerSharing peerAddress) + +deriving instance (Eq peerAddress) => Eq (PeerSharing peerAddress) + +instance Show (ClientHasAgency (st :: PeerSharing peerAddress)) where + show TokIdle = "TokIdle" + +instance Show (ServerHasAgency (st :: PeerSharing peerAddress)) where + show TokBusy = "TokBusy" + diff --git a/ouroboros-network-protocols/test-cddl/Main.hs b/ouroboros-network-protocols/test-cddl/Main.hs index 01a5aa0966c..a78253b45fa 100644 --- a/ouroboros-network-protocols/test-cddl/Main.hs +++ b/ouroboros-network-protocols/test-cddl/Main.hs @@ -11,6 +11,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -26,7 +27,11 @@ import qualified Codec.CBOR.Read as CBOR import Codec.CBOR.Term (Term (..)) import qualified Codec.CBOR.Term as CBOR import qualified Codec.CBOR.Write as CBOR +import Codec.Serialise.Class (Serialise) import qualified Codec.Serialise.Class as Serialise +import qualified Codec.Serialise.Decoding as CBOR +import qualified Codec.Serialise.Encoding as CBOR + import Data.Bool (bool) import qualified Data.ByteString.Lazy as BL @@ -35,6 +40,7 @@ import Data.List (sortOn) import qualified Data.Map as Map import Data.Ord (Down (..)) import qualified Data.Text as Text +import Data.Word (Word16) import System.Directory (doesDirectoryExist) import System.Exit (ExitCode (..)) @@ -52,12 +58,12 @@ import Ouroboros.Network.CodecCBORTerm import Ouroboros.Network.Magic import Ouroboros.Network.Mock.ConcreteBlock (Block, BlockHeader (..)) -import Ouroboros.Network.NodeToClient.Version - (NodeToClientVersion (..), NodeToClientVersionData (..), - nodeToClientCodecCBORTerm) +import Ouroboros.Network.NodeToClient.Version (NodeToClientVersion, + NodeToClientVersionData (..), nodeToClientCodecCBORTerm) import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..), NodeToNodeVersion (..), NodeToNodeVersionData (..), nodeToNodeCodecCBORTerm) +import Ouroboros.Network.PeerSelection.RelayAccessPoint (PortNumber) import Ouroboros.Network.Protocol.BlockFetch.Codec (codecBlockFetch) import Ouroboros.Network.Protocol.BlockFetch.Test () import Ouroboros.Network.Protocol.BlockFetch.Type (BlockFetch) @@ -97,15 +103,21 @@ import Ouroboros.Network.Protocol.TxSubmission2.Test (Tx, TxId) import Ouroboros.Network.Protocol.TxSubmission2.Type (TxSubmission2) import qualified Ouroboros.Network.Protocol.TxSubmission2.Type as TxSubmission2 +import Network.Socket (SockAddr (..)) import Ouroboros.Network.PeerSelection.PeerSharing.Type - (PeerSharing (..)) + (PeerSharing (..), decodeRemoteAddress, + encodeRemoteAddress) +import Ouroboros.Network.Protocol.PeerSharing.Codec (codecPeerSharing) +import Ouroboros.Network.Protocol.PeerSharing.Test () +import Ouroboros.Network.Protocol.PeerSharing.Type + (ClientHasAgency (TokIdle), ServerHasAgency (..)) +import qualified Ouroboros.Network.Protocol.PeerSharing.Type as PeerSharing import Test.QuickCheck import Test.QuickCheck.Instances.ByteString () import Test.Tasty (TestTree, adjustOption, defaultMain, testGroup) import Test.Tasty.HUnit import Test.Tasty.QuickCheck (QuickCheckMaxSize (..), testProperty) - -- | The main program, it requires both -- -- - 'cddl' program @@ -129,6 +141,7 @@ tests CDDLSpecs { cddlChainSync , cddlHandshakeNodeToNodeV7To10 , cddlHandshakeNodeToNodeV11 , cddlHandshakeNodeToClient + , cddlPeerSharing } = adjustOption (const $ QuickCheckMaxSize 10) $ testGroup "cddl" @@ -163,6 +176,8 @@ tests CDDLSpecs { cddlChainSync cddlLocalTxMonitor) , testProperty "LocalStateQuery" (prop_encodeLocalStateQuery cddlLocalStateQuery) + , testProperty "PeerSharing " (prop_encodePeerSharing + cddlPeerSharing) ] , testGroup "decoder" -- validate decoder by generating messages from the specification @@ -189,6 +204,8 @@ tests CDDLSpecs { cddlChainSync cddlLocalTxMonitor) , testCase "LocalStateQuery" (unit_decodeLocalStateQuery cddlLocalStateQuery) + , testCase "PeerSharing" (unit_decodePeerSharing + cddlPeerSharing) ] ] @@ -213,7 +230,8 @@ data CDDLSpecs = CDDLSpecs { cddlLocalTxMonitor :: CDDLSpec (LocalTxMonitor TxId Tx SlotNo), cddlLocalStateQuery :: CDDLSpec (LocalStateQuery Block (Point Block) - LocalStateQuery.Query) + LocalStateQuery.Query), + cddlPeerSharing :: CDDLSpec (PeerSharing.PeerSharing SockAddr) } @@ -233,6 +251,7 @@ readCDDLSpecs = do localTxSubmission <- BL.readFile (dir "local-tx-submission.cddl") localTxMonitor <- BL.readFile (dir "local-tx-monitor.cddl") localStateQuery <- BL.readFile (dir "local-state-query.cddl") + peerSharing <- BL.readFile (dir "peer-sharing.cddl") -- append common definitions; they must be appended since the first -- definition is the entry point for a cddl spec. return CDDLSpecs { @@ -251,6 +270,8 @@ readCDDLSpecs = do cddlLocalTxMonitor = CDDLSpec $ localTxMonitor <> common, cddlLocalStateQuery = CDDLSpec $ localStateQuery + <> common, + cddlPeerSharing = CDDLSpec $ peerSharing <> common } @@ -551,6 +572,25 @@ prop_encodeLocalStateQuery -> Property prop_encodeLocalStateQuery spec = validateEncoder spec localStateQueryCodec +instance Arbitrary PortNumber where + arbitrary = fromIntegral @Word16 <$> arbitrary + +instance Arbitrary SockAddr where + arbitrary = oneof [ SockAddrInet <$> arbitrary + <*> arbitrary + , SockAddrInet6 <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + ] + +prop_encodePeerSharing + :: CDDLSpec (PeerSharing.PeerSharing SockAddr) + -> AnyMessageAndAgency (PeerSharing.PeerSharing SockAddr) + -> Property +prop_encodePeerSharing spec = + validateEncoder spec (codecPeerSharing encodeRemoteAddress decodeRemoteAddress) + -- -- Test decoders @@ -767,6 +807,17 @@ unit_decodeLocalStateQuery spec = ] 100 +unit_decodePeerSharing + :: CDDLSpec (PeerSharing.PeerSharing SockAddr) + -> Assertion +unit_decodePeerSharing spec = + validateDecoder Nothing + spec (codecPeerSharing encodeRemoteAddress decodeRemoteAddress) + [ SomeAgency $ ClientAgency TokIdle + , SomeAgency $ ServerAgency TokBusy + ] + 100 + -- -- Utils diff --git a/ouroboros-network-protocols/test-cddl/specs/peer-sharing.cddl b/ouroboros-network-protocols/test-cddl/specs/peer-sharing.cddl new file mode 100644 index 00000000000..b46706211be --- /dev/null +++ b/ouroboros-network-protocols/test-cddl/specs/peer-sharing.cddl @@ -0,0 +1,22 @@ +; +; Peer Sharing MiniProtocol +; + +peerSharingMessage = msgShareRequest + / msgSharePeers + / msgDone + +msgShareRequest = [0, byte] +msgSharePeers = [1, peerAddresses] +msgDone = [2] + +peerAddresses = [* peerAddress] + +byte = 0..255 + +peerAddress = [0, word32, portNumber] ; ipv4 + portNumber + / [1, word32, word32, word32, word32, flowInfo, scopeId, portNumber] ; ipv6 + portNumber + +portNumber = word16 +flowInfo = word32 +scopeId = word32 diff --git a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Direct.hs b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Direct.hs new file mode 100644 index 00000000000..19dec24801e --- /dev/null +++ b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Direct.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Ouroboros.Network.Protocol.PeerSharing.Direct where + +import Ouroboros.Network.Protocol.PeerSharing.Client +import Ouroboros.Network.Protocol.PeerSharing.Server + +direct :: Monad m + => PeerSharingServer peer m + -> PeerSharingClient peer m b + -> m b +direct PeerSharingServer {} + (SendMsgDone mdone) = mdone +direct PeerSharingServer { recvMsgShareRequest } + (SendMsgShareRequest amount mclient) = do + (peers, server) <- recvMsgShareRequest amount + client <- mclient peers + direct server client diff --git a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Examples.hs b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Examples.hs new file mode 100644 index 00000000000..0e8eacf4a5b --- /dev/null +++ b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Examples.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Ouroboros.Network.Protocol.PeerSharing.Examples where + +import Ouroboros.Network.Protocol.PeerSharing.Client + (PeerSharingClient (..)) +import Ouroboros.Network.Protocol.PeerSharing.Server + (PeerSharingServer (..)) +import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharingAmount (..)) +import Data.Word (Word8) +import Test.QuickCheck.Function (Fun, applyFun) + + +-- | A client which collects answers whenever it receives +-- 'MsgSharePeers' and returns the result. +-- +peerSharingClientCollect :: forall peer m . Monad m + => [PeerSharingAmount] + -> PeerSharingClient peer m [peer] +peerSharingClientCollect = go [] + where + go :: [peer] -> [PeerSharingAmount] -> PeerSharingClient peer m [peer] + go acc [] = SendMsgDone (pure acc) + go acc (h:t) = SendMsgShareRequest h (\r -> return (go (r ++ acc) t)) + + +-- | A server which counts number received of 'MsgPeerShareRequest'. +-- +peerSharingServerReplicate :: forall m . Monad m + => Fun Word8 Int + -> PeerSharingServer Int m +peerSharingServerReplicate f = go 0 + where + go :: Int -> PeerSharingServer Int m + go n = + PeerSharingServer + { recvMsgShareRequest = \ (PeerSharingAmount amount) -> do + let r = replicate (applyFun f amount) n + return (r, go (n + 1)) + } diff --git a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Test.hs b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Test.hs new file mode 100644 index 00000000000..56b2261f89e --- /dev/null +++ b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Test.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} + +module Ouroboros.Network.Protocol.PeerSharing.Test where + +import qualified Codec.Serialise as CBOR +import Control.Monad.Class.MonadAsync (MonadAsync) +import Control.Monad.Class.MonadST (MonadST) +import Control.Monad.Class.MonadThrow (MonadCatch) +import Control.Monad.IOSim (runSimOrThrow) +import Control.Monad.ST (runST) +import Control.Tracer (nullTracer) +import qualified Data.ByteString.Lazy as BL +import Data.Foldable (foldl') +import Network.TypedProtocol.Codec (AnyMessage (..), + AnyMessageAndAgency (..), Codec (..), PeerHasAgency (..), + prop_codecM, prop_codec_splitsM) +import Network.TypedProtocol.Proofs (TerminalStates (..), connect) +import Ouroboros.Network.Channel (createConnectedChannels) +import Ouroboros.Network.Driver.Limits (ProtocolSizeLimits (..)) +import Ouroboros.Network.Driver.Simple (runConnectedPeers) +import Ouroboros.Network.Protocol.PeerSharing.Client + (peerSharingClientPeer) +import Ouroboros.Network.Protocol.PeerSharing.Codec + (byteLimitsPeerSharing, codecPeerSharing) +import Ouroboros.Network.Protocol.PeerSharing.Direct (direct) +import Ouroboros.Network.Protocol.PeerSharing.Examples + (peerSharingClientCollect, peerSharingServerReplicate) +import Ouroboros.Network.Protocol.PeerSharing.Server + (peerSharingServerPeer) +import Ouroboros.Network.Protocol.PeerSharing.Type + (ClientHasAgency (..), Message (..), NobodyHasAgency (..), + PeerSharing, PeerSharingAmount (..), ServerHasAgency (..)) +import Test.Ouroboros.Network.Testing.Utils (prop_codec_cborM, + prop_codec_valid_cbor_encoding, splits2, splits3) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (Arbitrary (..), Property, ioProperty, + oneof, testProperty, withMaxSuccess, (===)) +import Data.Word (Word8) +import Test.QuickCheck.Function (Fun, applyFun) + +tests :: TestTree +tests = + testGroup "Ouroboros.Network.Protocol" + [ testGroup "PeerSharing" + [ testProperty "direct" prop_direct + , testProperty "connect" prop_connect + , testProperty "channel ST" prop_channel_ST + , testProperty "channel IO" prop_channel_IO + , testProperty "codec" prop_codec + , testProperty "codec cbor" prop_codec_cbor + , testProperty "codec valid cbor" prop_codec_valid_cbor + , testProperty "codec 2-splits" prop_codec_splits2 + , testProperty "codec 3-splits" (withMaxSuccess 33 prop_codec_splits3) + , testProperty "byteLimits" prop_byteLimits + ] + ] + +instance Arbitrary PeerSharingAmount where + arbitrary = PeerSharingAmount <$> arbitrary + shrink (PeerSharingAmount amount) = PeerSharingAmount <$> shrink amount + +-- +-- Properties going directly, not via Peer. +-- + +prop_direct :: Fun Word8 Int -> [PeerSharingAmount] -> Property +prop_direct f l = + runSimOrThrow + (direct (peerSharingServerReplicate f) + (peerSharingClientCollect l)) + === (snd $ foldl' (\(n, r) (PeerSharingAmount amount) + -> (n + 1, replicate (applyFun f amount) n ++ r)) + (0, []) + l) + +-- +-- Properties using connect +-- + +prop_connect :: Fun Word8 Int -> [PeerSharingAmount] -> Property +prop_connect f l = + case runSimOrThrow + (connect + (peerSharingClientPeer (peerSharingClientCollect l)) + (peerSharingServerPeer (peerSharingServerReplicate f))) of + (ns, _, TerminalStates TokDone TokDone) -> + let compute = foldl' (\(x, r) (PeerSharingAmount amount) + -> (x + 1, replicate (applyFun f amount) x ++ r)) + (0, []) + l + in ns === snd compute + + +-- +-- Properties using channels, codecs and drivers. +-- + +prop_channel :: ( MonadST m + , MonadAsync m + , MonadCatch m + ) + => Fun Word8 Int + -> [PeerSharingAmount] + -> m Property +prop_channel f l = do + (s, _) <- runConnectedPeers createConnectedChannels + nullTracer + (codecPeerSharing CBOR.encode CBOR.decode) + client server + let compute = foldl' (\(x, r) (PeerSharingAmount amount) + -> (x + 1, replicate (applyFun f amount) x ++ r)) + (0, []) + l + return (s === snd compute) + where + client = peerSharingClientPeer (peerSharingClientCollect l) + server = peerSharingServerPeer (peerSharingServerReplicate f) + +prop_channel_ST :: Fun Word8 Int + -> [PeerSharingAmount] + -> Property +prop_channel_ST f l = + runSimOrThrow (prop_channel f l) + +prop_channel_IO :: Fun Word8 Int + -> [PeerSharingAmount] + -> Property +prop_channel_IO f l = + ioProperty (prop_channel f l) + +-- +-- Codec tests +-- + +instance Arbitrary peer => Arbitrary (AnyMessageAndAgency (PeerSharing peer)) where + arbitrary = do + amount <- arbitrary + resp <- arbitrary + oneof + [ pure $ AnyMessageAndAgency (ClientAgency TokIdle) (MsgShareRequest amount) + , pure $ AnyMessageAndAgency (ServerAgency TokBusy) (MsgSharePeers resp) + , pure $ AnyMessageAndAgency (ClientAgency TokIdle) MsgDone + ] + +instance Eq peer => Eq (AnyMessage (PeerSharing peer)) where + AnyMessage (MsgShareRequest amountA) == AnyMessage (MsgShareRequest amountB) = amountA == amountB + AnyMessage (MsgSharePeers respA) == AnyMessage (MsgSharePeers respB) = respA == respB + AnyMessage MsgDone == AnyMessage MsgDone = True + _ == _ = False + +prop_codec :: AnyMessageAndAgency (PeerSharing Int) + -> Bool +prop_codec msg = + runST (prop_codecM (codecPeerSharing CBOR.encode CBOR.decode) msg) + +prop_codec_cbor + :: AnyMessageAndAgency (PeerSharing Int) + -> Bool +prop_codec_cbor msg = + runST (prop_codec_cborM (codecPeerSharing CBOR.encode CBOR.decode) msg) + +prop_codec_valid_cbor :: AnyMessageAndAgency (PeerSharing Int) -> Property +prop_codec_valid_cbor = prop_codec_valid_cbor_encoding (codecPeerSharing CBOR.encode CBOR.decode) + +-- | Check for data chunk boundary problems in the codec using 2 chunks. +-- +prop_codec_splits2 :: AnyMessageAndAgency (PeerSharing Int) -> Bool +prop_codec_splits2 msg = + runST (prop_codec_splitsM splits2 (codecPeerSharing CBOR.encode CBOR.decode) msg) + +-- | Check for data chunk boundary problems in the codec using 3 chunks. +-- +prop_codec_splits3 :: AnyMessageAndAgency (PeerSharing Int) -> Bool +prop_codec_splits3 msg = + runST (prop_codec_splitsM splits3 (codecPeerSharing CBOR.encode CBOR.decode) msg) + +prop_byteLimits :: AnyMessageAndAgency (PeerSharing Int) + -> Bool +prop_byteLimits (AnyMessageAndAgency agency msg) = + dataSize (encode agency msg) + <= sizeLimitForState agency + where + Codec { encode } = codecPeerSharing @IO (CBOR.encode @Int) (CBOR.decode @Int) + ProtocolSizeLimits { sizeLimitForState, dataSize } = + byteLimitsPeerSharing (fromIntegral . BL.length) diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 8e94b84c4ab..09be2e92590 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -57,6 +57,7 @@ library Ouroboros.Network.PeerSelection.RootPeersDNS Ouroboros.Network.PeerSelection.Governor Ouroboros.Network.PeerSelection.Simple + Ouroboros.Network.PeerSharing Ouroboros.Network.TxSubmission.Inbound Ouroboros.Network.TxSubmission.Mempool.Reader Ouroboros.Network.TxSubmission.Outbound @@ -234,8 +235,6 @@ test-suite test -rtsopts +RTS -T -RTS - - executable demo-chain-sync hs-source-dirs: demo main-is: chain-sync.hs diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs index e8ba399b4e3..516fc1690f2 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs @@ -7,6 +7,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + -- | This is the starting point for a module that will bring together the -- overall node to node protocol, as a collection of mini-protocols. -- @@ -148,6 +150,7 @@ import Ouroboros.Network.Subscription.Worker (LocalAddresses (..), import Ouroboros.Network.Tracers import qualified Ouroboros.Network.TxSubmission.Inbound as TxInbound import qualified Ouroboros.Network.TxSubmission.Outbound as TxOutbound +import Ouroboros.Network.Util.ShowProxy (ShowProxy, showProxy) -- The Handshake tracer types are simply terrible. @@ -684,4 +687,8 @@ localNetworkErrorPolicy = ErrorPolicies { } type RemoteAddress = Socket.SockAddr + +instance ShowProxy RemoteAddress where + showProxy _ = "SockAddr" + type RemoteConnectionId = ConnectionId RemoteAddress diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSharing.hs b/ouroboros-network/src/Ouroboros/Network/PeerSharing.hs new file mode 100644 index 00000000000..cb9cb2368ff --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/PeerSharing.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TupleSections #-} +module Ouroboros.Network.PeerSharing where + +import Ouroboros.Network.Protocol.PeerSharing.Client + (PeerSharingClient (..)) +import Ouroboros.Network.Protocol.PeerSharing.Server + (PeerSharingServer (..)) +import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharingAmount) + +peerSharingClient :: Monad m + => PeerSharingAmount + -> PeerSharingClient peer m [peer] +peerSharingClient amount = + SendMsgShareRequest amount (return . SendMsgDone . return) + + +peerSharingServer :: Monad m + => (PeerSharingAmount -> m [peer]) + -> PeerSharingServer peer m +peerSharingServer computePeersToShare = + PeerSharingServer + { recvMsgShareRequest = \amount -> (,) <$> computePeersToShare amount + <*> return (peerSharingServer computePeersToShare) + } diff --git a/ouroboros-network/test/Main.hs b/ouroboros-network/test/Main.hs index eb3e9c1fcb7..a934fda1fb8 100644 --- a/ouroboros-network/test/Main.hs +++ b/ouroboros-network/test/Main.hs @@ -9,6 +9,7 @@ import qualified Ouroboros.Network.Protocol.KeepAlive.Test (tests) import qualified Ouroboros.Network.Protocol.LocalStateQuery.Test (tests) import qualified Ouroboros.Network.Protocol.LocalTxMonitor.Test (tests) import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Test (tests) +import qualified Ouroboros.Network.Protocol.PeerSharing.Test (tests) import qualified Ouroboros.Network.Protocol.TxSubmission2.Test (tests) import qualified Test.ChainProducerState (tests) import qualified Test.LedgerPeers (tests) @@ -50,6 +51,7 @@ tests = , Ouroboros.Network.Protocol.TxSubmission2.Test.tests , Ouroboros.Network.Protocol.Handshake.Test.tests , Ouroboros.Network.Protocol.KeepAlive.Test.tests + , Ouroboros.Network.Protocol.PeerSharing.Test.tests -- network logic , Test.Version.tests diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Orphans.hs b/ouroboros-network/test/Test/Ouroboros/Network/Orphans.hs index 7c2600fc55a..323795815d9 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Orphans.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Orphans.hs @@ -16,4 +16,3 @@ instance Hashable IP.IP instance Hashable PortNumber where hashWithSalt salt pn = hashUsing (fromIntegral :: PortNumber -> Word16) salt pn -