Skip to content
Permalink
Browse files

Merge #425

425: Version negotiation protocol r=coot a=coot

It is not yet integrated with `muxStart` function, only because this requires to model ouroboros-network api which I will do in another PR.

The PR contains:
-  `VersionNegotiation` `typed-protocol` under `Ouroboros.Network.Protocol.VersionNegotiation`
- client and server `Peer`s
- codec

Tests contain:
- test using `connect`
- test using a channel
- codec tests, which includes receiving not valid data (though not sending arbitrary cborg terms, as in `karknu/mux-ver`, this can be added later)

Co-authored-by: Marcin Szamotulski <profunctor@pm.me>
  • Loading branch information...
iohk-bors and coot committed May 15, 2019
2 parents db64fb4 + fe9b0ad commit e2e24153240d7c1f41d61d894bb4e607d5a9eb0d
@@ -50,7 +50,6 @@ library
Ouroboros.Network.NodeToClient
Ouroboros.Network.Pipe
Ouroboros.Network.Server.Socket
Ouroboros.Network.Server.Version
Ouroboros.Network.Server.Version.CBOR
Ouroboros.Network.Server.Version.Protocol
Ouroboros.Network.Socket
@@ -65,6 +64,9 @@ library
Ouroboros.Network.Protocol.BlockFetch.Client
Ouroboros.Network.Protocol.BlockFetch.Server
Ouroboros.Network.Protocol.BlockFetch.Codec
Ouroboros.Network.Protocol.Handshake.Type
Ouroboros.Network.Protocol.Handshake.Codec
Ouroboros.Network.Protocol.Handshake.Version
default-language: Haskell2010
other-extensions: BangPatterns,
DataKinds,
@@ -166,6 +168,10 @@ test-suite tests
Ouroboros.Network.Protocol.PingPong.Test
Ouroboros.Network.Protocol.ReqResp.Codec
Ouroboros.Network.Protocol.ReqResp.Test
Ouroboros.Network.Protocol.Handshake.Type
Ouroboros.Network.Protocol.Handshake.Codec
Ouroboros.Network.Protocol.Handshake.Test
Ouroboros.Network.Protocol.Handshake.Version
Ouroboros.Network.Socket
Ouroboros.Network.Server.Socket
Ouroboros.Network.Time
@@ -0,0 +1,124 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Ouroboros.Network.Protocol.Handshake.Codec
( codecHandshake
, SerialiseTerm (..)
) where

import Control.Monad.Class.MonadST
import Control.Monad (unless)
import Data.Text (Text)
import Data.ByteString.Lazy (ByteString)
import Data.Map (Map)
import qualified Data.Map as Map

import qualified Codec.CBOR.Encoding as CBOR
import qualified Codec.CBOR.Decoding as CBOR
import qualified Codec.CBOR.Read as CBOR
import qualified Codec.CBOR.Term as CBOR
import Codec.Serialise (Serialise)
import qualified Codec.Serialise as CBOR

import Network.TypedProtocol.Codec hiding (encode, decode)
import Ouroboros.Network.Codec (mkCodecCborLazyBS)

import Ouroboros.Network.Protocol.Handshake.Type


-- |
-- Decoding proposed version is done in two stages. First decode
-- a @'CBOR.Term'@, this is done by @'codecHandshake'@, the second
-- phase is handled by interface defined in this type class and it is used by
-- @'handshakeClientPeer'@ and @'handshakeServerPeer'@.
--
-- todo: find a better place for this class
class SerialiseTerm a where
encodeTerm :: a -> CBOR.Term
decodeTerm :: CBOR.Term -> Either Text a

-- |
-- @'Handshake'@ codec. The @'MsgProposeVersions'@ encodes proposed map in
-- ascending order and it expects to receive them in this order. This allows
-- to construct the map in linear time. There is also another limiting factor
-- to the number of versions on can present: the whole message must fit into
-- a single TCP segment.
--
codecHandshake
:: forall vNumber m.
( Monad m
, MonadST m
, Ord vNumber
, Enum vNumber
, Serialise vNumber
, Show vNumber
)
=> Codec (Handshake vNumber CBOR.Term) CBOR.DeserialiseFailure m ByteString
codecHandshake = mkCodecCborLazyBS encode decode
where
encode :: forall (pr :: PeerRole) st st'.
PeerHasAgency pr st
-> Message (Handshake vNumber CBOR.Term) st st'
-> CBOR.Encoding

encode (ClientAgency TokPropose) (MsgProposeVersions vs) =
let vs' = Map.toAscList vs
in
CBOR.encodeListLen 2
<> CBOR.encodeWord 0
<> CBOR.encodeMapLen (fromIntegral $ length vs')
<> mconcat [ CBOR.encode vNumber
<> CBOR.encodeTerm vParams
| (vNumber, vParams) <- vs'
]

encode (ServerAgency TokConfirm) (MsgAcceptVersion vNumber vParams) =
CBOR.encodeListLen 3
<> CBOR.encodeWord 1
<> CBOR.encode vNumber
<> CBOR.encodeTerm vParams

encode (ServerAgency TokConfirm) (MsgRefuse vReason) =
CBOR.encodeListLen 2
<> CBOR.encodeWord 2
<> CBOR.encode vReason

-- decode a map checking the assumption that
-- * keys are different
-- * keys are encoded in ascending order
-- fail when one of these assumptions is not met
decodeMap :: Int
-> Maybe vNumber
-> [(vNumber, CBOR.Term)]
-> CBOR.Decoder s (Map vNumber CBOR.Term)
decodeMap 0 _ !vs = return $ Map.fromDistinctAscList $ reverse vs
decodeMap !l !prev !vs = do
vNumber <- CBOR.decode
let next = Just vNumber
unless (next > prev)
$ fail "codecHandshake.Propose: unordered version"
vParams <- CBOR.decodeTerm
decodeMap (pred l) next ((vNumber,vParams) : vs)

decode :: forall (pr :: PeerRole) s (st :: Handshake vNumber CBOR.Term).
PeerHasAgency pr st
-> CBOR.Decoder s (SomeMessage st)
decode stok = do
_ <- CBOR.decodeListLen
key <- CBOR.decodeWord
case (stok, key) of
(ClientAgency TokPropose, 0) -> do
l <- CBOR.decodeMapLen
vMap <- decodeMap l Nothing []
pure $ SomeMessage $ MsgProposeVersions vMap
(ServerAgency TokConfirm, 1) ->
SomeMessage <$> (MsgAcceptVersion <$> CBOR.decode <*> CBOR.decodeTerm)
(ServerAgency TokConfirm, 2) -> SomeMessage . MsgRefuse <$> CBOR.decode

(ClientAgency TokPropose, _) -> fail "codecHandshake.Propose: unexpected key"
(ServerAgency TokConfirm, _) -> fail "codecHandshake.Confirm: unexpected key"
Oops, something went wrong.

0 comments on commit e2e2415

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