Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Create PeerSharing Typed Protocol and tests Add Peer Sharing CDDL spec and tests
- Loading branch information
Showing
16 changed files
with
735 additions
and
16 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
38 changes: 38 additions & 0 deletions
38
ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Client.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -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 |
135 changes: 135 additions & 0 deletions
135
ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Codec.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -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 |
39 changes: 39 additions & 0 deletions
39
ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Server.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -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 () |
Oops, something went wrong.