{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

module Ouroboros.Network.Protocol.Handshake.Codec
  ( codecHandshake
  , byteLimitsHandshake
  , timeLimitsHandshake
  , noTimeLimitsHandshake
  , encodeRefuseReason
  , decodeRefuseReason
    -- ** Version data codec
  , VersionDataCodec (..)
  , cborTermVersionDataCodec
    -- * NodeToNode & NodeToClient Codecs
  , nodeToNodeHandshakeCodec
  , nodeToClientHandshakeCodec
  ) where

import           Control.Monad (replicateM, unless)
import           Control.Monad.Class.MonadST
import           Control.Monad.Class.MonadTime.SI
import           Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BL
import           Data.Either (partitionEithers)
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Maybe (mapMaybe)
import           Data.Text (Text)
import           Text.Printf

import           Network.TypedProtocol.Codec.CBOR

import qualified Codec.CBOR.Decoding as CBOR
import qualified Codec.CBOR.Encoding as CBOR
import qualified Codec.CBOR.Read as CBOR
import qualified Codec.CBOR.Term as CBOR

import           Ouroboros.Network.CodecCBORTerm
import           Ouroboros.Network.Driver.Limits

import           Ouroboros.Network.Protocol.Handshake.Type
import           Ouroboros.Network.Protocol.Limits

import           Ouroboros.Network.NodeToClient.Version (NodeToClientVersion,
                     nodeToClientVersionCodec)
import           Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion,
                     nodeToNodeVersionCodec)

-- | Codec for version data ('vData' in code) exchanged by the handshake
-- protocol.
--
-- Note: 'extra' type param is instantiated to 'DictVersion'; 'agreedOptions'
-- is instantiated to 'NodeToNodeVersionData' in "Ouroboros.Network.NodeToNode"
-- or to '()' in "Ouroboros.Network.NodeToClient".
--
data VersionDataCodec bytes vNumber vData = VersionDataCodec {
    forall bytes vNumber vData.
VersionDataCodec bytes vNumber vData -> vNumber -> vData -> bytes
encodeData :: vNumber -> vData -> bytes,
    -- ^ encoder of 'vData' which has access to 'extra vData' which can bring
    -- extra instances into the scope (by means of pattern matching on a GADT).
    forall bytes vNumber vData.
VersionDataCodec bytes vNumber vData
-> vNumber -> bytes -> Either Text vData
decodeData :: vNumber -> bytes -> Either Text vData
    -- ^ decoder of 'vData'.
  }

-- TODO: remove this from top level API, this is the only way we encode or
-- decode version data.
cborTermVersionDataCodec :: (vNumber -> CodecCBORTerm Text vData)
                         -> VersionDataCodec CBOR.Term vNumber vData
cborTermVersionDataCodec :: forall vNumber vData.
(vNumber -> CodecCBORTerm Text vData)
-> VersionDataCodec Term vNumber vData
cborTermVersionDataCodec vNumber -> CodecCBORTerm Text vData
codec = VersionDataCodec {
      encodeData :: vNumber -> vData -> Term
encodeData = forall fail a. CodecCBORTerm fail a -> a -> Term
encodeTerm forall b c a. (b -> c) -> (a -> b) -> a -> c
. vNumber -> CodecCBORTerm Text vData
codec,
      decodeData :: vNumber -> Term -> Either Text vData
decodeData = forall fail a. CodecCBORTerm fail a -> Term -> Either fail a
decodeTerm forall b c a. (b -> c) -> (a -> b) -> a -> c
. vNumber -> CodecCBORTerm Text vData
codec
    }

-- |
-- 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 handshake
-- protocol.
--
maxTransmissionUnit :: Word
maxTransmissionUnit :: Word
maxTransmissionUnit = Word
4 forall a. Num a => a -> a -> a
* Word
1440

-- | Byte limits
byteLimitsHandshake :: forall vNumber. ProtocolSizeLimits (Handshake vNumber CBOR.Term) ByteString
byteLimitsHandshake :: forall {k} (vNumber :: k).
ProtocolSizeLimits (Handshake vNumber Term) ByteString
byteLimitsHandshake = forall ps bytes.
(forall (pr :: PeerRole) (st :: ps). PeerHasAgency pr st -> Word)
-> (bytes -> Word) -> ProtocolSizeLimits ps bytes
ProtocolSizeLimits forall (pr :: PeerRole) (st :: Handshake vNumber Term).
PeerHasAgency pr st -> Word
stateToLimit (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length)
  where
    stateToLimit :: forall (pr :: PeerRole) (st  :: Handshake vNumber CBOR.Term).
                    PeerHasAgency pr st -> Word
    stateToLimit :: forall (pr :: PeerRole) (st :: Handshake vNumber Term).
PeerHasAgency pr st -> Word
stateToLimit (ClientAgency ClientHasAgency st
R:ClientHasAgencyHandshakest k (*) vNumber Term st
TokPropose) = Word
maxTransmissionUnit
    stateToLimit (ServerAgency ServerHasAgency st
R:ServerHasAgencyHandshakest k (*) vNumber Term st
TokConfirm) = Word
maxTransmissionUnit

-- | Time limits.
--
timeLimitsHandshake :: forall vNumber. ProtocolTimeLimits (Handshake vNumber CBOR.Term)
timeLimitsHandshake :: forall {k} (vNumber :: k).
ProtocolTimeLimits (Handshake vNumber Term)
timeLimitsHandshake = forall ps.
(forall (pr :: PeerRole) (st :: ps).
 PeerHasAgency pr st -> Maybe DiffTime)
-> ProtocolTimeLimits ps
ProtocolTimeLimits forall (pr :: PeerRole) (st :: Handshake vNumber Term).
PeerHasAgency pr st -> Maybe DiffTime
stateToLimit
  where
    stateToLimit :: forall (pr :: PeerRole) (st  :: Handshake vNumber CBOR.Term).
                    PeerHasAgency pr st -> Maybe DiffTime
    stateToLimit :: forall (pr :: PeerRole) (st :: Handshake vNumber Term).
PeerHasAgency pr st -> Maybe DiffTime
stateToLimit (ClientAgency ClientHasAgency st
R:ClientHasAgencyHandshakest k (*) vNumber Term st
TokPropose) = Maybe DiffTime
shortWait
    stateToLimit (ServerAgency ServerHasAgency st
R:ServerHasAgencyHandshakest k (*) vNumber Term st
TokConfirm) = Maybe DiffTime
shortWait


noTimeLimitsHandshake :: forall vNumber. ProtocolTimeLimits (Handshake vNumber CBOR.Term)
noTimeLimitsHandshake :: forall {k} (vNumber :: k).
ProtocolTimeLimits (Handshake vNumber Term)
noTimeLimitsHandshake = forall ps.
(forall (pr :: PeerRole) (st :: ps).
 PeerHasAgency pr st -> Maybe DiffTime)
-> ProtocolTimeLimits ps
ProtocolTimeLimits forall (pr :: PeerRole) (st :: Handshake vNumber Term).
PeerHasAgency pr st -> Maybe DiffTime
stateToLimit
  where
    stateToLimit :: forall (pr :: PeerRole) (st  :: Handshake vNumber CBOR.Term).
                    PeerHasAgency pr st -> Maybe DiffTime
    stateToLimit :: forall (pr :: PeerRole) (st :: Handshake vNumber Term).
PeerHasAgency pr st -> Maybe DiffTime
stateToLimit (ClientAgency ClientHasAgency st
R:ClientHasAgencyHandshakest k (*) vNumber Term st
TokPropose) = forall a. Maybe a
Nothing
    stateToLimit (ServerAgency ServerHasAgency st
R:ServerHasAgencyHandshakest k (*) vNumber Term st
TokConfirm) = forall a. Maybe a
Nothing


-- |
-- @'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 failure.
     ( MonadST m
     , Ord vNumber
     , Show failure
     )
  => CodecCBORTerm (failure, Maybe Int) vNumber
  -> Codec (Handshake vNumber CBOR.Term) CBOR.DeserialiseFailure m ByteString
codecHandshake :: forall vNumber (m :: * -> *) failure.
(MonadST m, Ord vNumber, Show failure) =>
CodecCBORTerm (failure, Maybe Int) vNumber
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
codecHandshake CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec = forall ps (m :: * -> *).
MonadST m =>
(forall (pr :: PeerRole) (st :: ps) (st' :: ps).
 PeerHasAgency pr st -> Message ps st st' -> Encoding)
-> (forall (pr :: PeerRole) (st :: ps) s.
    PeerHasAgency pr st -> Decoder s (SomeMessage st))
-> Codec ps DeserialiseFailure m ByteString
mkCodecCborLazyBS forall (pr :: PeerRole) (st :: Handshake vNumber Term)
       (st' :: Handshake vNumber Term).
PeerHasAgency pr st
-> Message (Handshake vNumber Term) st st' -> Encoding
encodeMsg forall (pr :: PeerRole) s (st :: Handshake vNumber Term).
PeerHasAgency pr st -> Decoder s (SomeMessage st)
decodeMsg
    where
      encodeMsg
        :: forall (pr :: PeerRole) st st'.
           PeerHasAgency pr st
        -> Message (Handshake vNumber CBOR.Term) st st'
        -> CBOR.Encoding

      encodeMsg :: forall (pr :: PeerRole) (st :: Handshake vNumber Term)
       (st' :: Handshake vNumber Term).
PeerHasAgency pr st
-> Message (Handshake vNumber Term) st st' -> Encoding
encodeMsg (ClientAgency ClientHasAgency st
R:ClientHasAgencyHandshakest (*) (*) vNumber Term st
TokPropose) (MsgProposeVersions Map vNumber vParams
vs) =
           Word -> Encoding
CBOR.encodeListLen Word
2
        forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
0
        forall a. Semigroup a => a -> a -> a
<> forall failure vNumber.
CodecCBORTerm (failure, Maybe Int) vNumber
-> Map vNumber Term -> Encoding
encodeVersions CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec Map vNumber vParams
vs

      -- Although `MsgReplyVersions` shall not be sent, for testing purposes it
      -- is useful to have an encoder for it.
      encodeMsg (ServerAgency ServerHasAgency st
R:ServerHasAgencyHandshakest (*) (*) vNumber Term st
TokConfirm) (MsgReplyVersions Map vNumber vParams
vs)
        = Word -> Encoding
CBOR.encodeListLen Word
2
        forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
0
        forall a. Semigroup a => a -> a -> a
<> forall failure vNumber.
CodecCBORTerm (failure, Maybe Int) vNumber
-> Map vNumber Term -> Encoding
encodeVersions CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec Map vNumber vParams
vs

      encodeMsg (ServerAgency ServerHasAgency st
R:ServerHasAgencyHandshakest (*) (*) vNumber Term st
TokConfirm) (MsgAcceptVersion vNumber
vNumber vParams
vParams) =
           Word -> Encoding
CBOR.encodeListLen Word
3
        forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
1
        forall a. Semigroup a => a -> a -> a
<> Term -> Encoding
CBOR.encodeTerm (forall fail a. CodecCBORTerm fail a -> a -> Term
encodeTerm CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec vNumber
vNumber)
        forall a. Semigroup a => a -> a -> a
<> Term -> Encoding
CBOR.encodeTerm vParams
vParams

      encodeMsg (ServerAgency ServerHasAgency st
R:ServerHasAgencyHandshakest (*) (*) vNumber Term st
TokConfirm) (MsgRefuse RefuseReason vNumber
vReason) =
           Word -> Encoding
CBOR.encodeListLen Word
2
        forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
2
        forall a. Semigroup a => a -> a -> a
<> forall fail vNumber.
CodecCBORTerm fail vNumber -> RefuseReason vNumber -> Encoding
encodeRefuseReason CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec RefuseReason vNumber
vReason

      encodeMsg (ServerAgency ServerHasAgency st
R:ServerHasAgencyHandshakest (*) (*) vNumber Term st
TokConfirm) (MsgQueryReply Map vNumber vParams
vs)
        = Word -> Encoding
CBOR.encodeListLen Word
2
        forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
3
        forall a. Semigroup a => a -> a -> a
<> forall failure vNumber.
CodecCBORTerm (failure, Maybe Int) vNumber
-> Map vNumber Term -> Encoding
encodeVersions CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec Map vNumber vParams
vs

      decodeMsg :: forall (pr :: PeerRole) s (st :: Handshake vNumber CBOR.Term).
                   PeerHasAgency pr st
                -> CBOR.Decoder s (SomeMessage st)
      decodeMsg :: forall (pr :: PeerRole) s (st :: Handshake vNumber Term).
PeerHasAgency pr st -> Decoder s (SomeMessage st)
decodeMsg PeerHasAgency pr st
stok = do
        Int
len <- forall s. Decoder s Int
CBOR.decodeListLen
        Word
key <- forall s. Decoder s Word
CBOR.decodeWord
        case (PeerHasAgency pr st
stok, Word
key, Int
len) of
          (ClientAgency ClientHasAgency st
R:ClientHasAgencyHandshakest (*) (*) vNumber Term st
TokPropose, Word
0, Int
2) -> do
            Int
l  <- forall s. Decoder s Int
CBOR.decodeMapLen
            Map vNumber Term
vMap <- forall vNumber failure s.
Ord vNumber =>
CodecCBORTerm (failure, Maybe Int) vNumber
-> Int -> Decoder s (Map vNumber Term)
decodeVersions CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec Int
l
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall ps (st :: ps) (st' :: ps).
Message ps st st' -> SomeMessage st
SomeMessage forall a b. (a -> b) -> a -> b
$ forall vNumber vParams.
Map vNumber vParams
-> Message (Handshake vNumber vParams) 'StPropose 'StConfirm
MsgProposeVersions Map vNumber Term
vMap
          (ServerAgency ServerHasAgency st
R:ServerHasAgencyHandshakest (*) (*) vNumber Term st
TokConfirm, Word
0, Int
2) -> do
            Int
l  <- forall s. Decoder s Int
CBOR.decodeMapLen
            Map vNumber Term
vMap <- forall vNumber failure s.
Ord vNumber =>
CodecCBORTerm (failure, Maybe Int) vNumber
-> Int -> Decoder s (Map vNumber Term)
decodeVersions CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec Int
l
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall ps (st :: ps) (st' :: ps).
Message ps st st' -> SomeMessage st
SomeMessage forall a b. (a -> b) -> a -> b
$ forall vNumber vParams.
Map vNumber vParams
-> Message (Handshake vNumber vParams) 'StConfirm 'StDone
MsgReplyVersions Map vNumber Term
vMap
          (ServerAgency ServerHasAgency st
R:ServerHasAgencyHandshakest (*) (*) vNumber Term st
TokConfirm, Word
1, Int
3) -> do
            Either (failure, Maybe Int) vNumber
v <- forall fail a. CodecCBORTerm fail a -> Term -> Either fail a
decodeTerm CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Term
CBOR.decodeTerm
            case Either (failure, Maybe Int) vNumber
v of
              -- at this stage we can throw exception when decoding
              -- version number: 'MsgAcceptVersion' must send us back
              -- version which we know how to decode
              Left (failure, Maybe Int)
e -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"codecHandshake.MsgAcceptVersion: not recognized version: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (failure, Maybe Int)
e)
              Right vNumber
vNumber ->
                forall ps (st :: ps) (st' :: ps).
Message ps st st' -> SomeMessage st
SomeMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall vNumber vParams.
vNumber
-> vParams
-> Message (Handshake vNumber vParams) 'StConfirm 'StDone
MsgAcceptVersion vNumber
vNumber forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Term
CBOR.decodeTerm
          (ServerAgency ServerHasAgency st
R:ServerHasAgencyHandshakest (*) (*) vNumber Term st
TokConfirm, Word
2, Int
2) ->
            forall ps (st :: ps) (st' :: ps).
Message ps st st' -> SomeMessage st
SomeMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} vNumber (vParams :: k).
RefuseReason vNumber
-> Message (Handshake vNumber vParams) 'StConfirm 'StDone
MsgRefuse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall failure vNumber s.
Show failure =>
CodecCBORTerm (failure, Maybe Int) vNumber
-> Decoder s (RefuseReason vNumber)
decodeRefuseReason CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec
          (ServerAgency ServerHasAgency st
R:ServerHasAgencyHandshakest (*) (*) vNumber Term st
TokConfirm, Word
3, Int
2) -> do
            Int
l  <- forall s. Decoder s Int
CBOR.decodeMapLen
            Map vNumber Term
vMap <- forall vNumber failure s.
Ord vNumber =>
CodecCBORTerm (failure, Maybe Int) vNumber
-> Int -> Decoder s (Map vNumber Term)
decodeVersions CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec Int
l
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall ps (st :: ps) (st' :: ps).
Message ps st st' -> SomeMessage st
SomeMessage forall a b. (a -> b) -> a -> b
$ forall vNumber vParams.
Map vNumber vParams
-> Message (Handshake vNumber vParams) 'StConfirm 'StDone
MsgQueryReply Map vNumber Term
vMap

          (ClientAgency ClientHasAgency st
R:ClientHasAgencyHandshakest (*) (*) vNumber Term st
TokPropose, Word
_, Int
_) ->
            forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"codecHandshake (%s) unexpected key (%d, %d)" (forall a. Show a => a -> String
show PeerHasAgency pr st
stok) Word
key Int
len
          (ServerAgency ServerHasAgency st
R:ServerHasAgencyHandshakest (*) (*) vNumber Term st
TokConfirm, Word
_, Int
_) ->
            forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"codecHandshake (%s) unexpected key (%d, %d)" (forall a. Show a => a -> String
show PeerHasAgency pr st
stok) Word
key Int
len


-- | Encode version map preserving the ascending order of keys.
--
encodeVersions :: CodecCBORTerm (failure, Maybe Int) vNumber
               -> Map vNumber CBOR.Term
               -> CBOR.Encoding
encodeVersions :: forall failure vNumber.
CodecCBORTerm (failure, Maybe Int) vNumber
-> Map vNumber Term -> Encoding
encodeVersions CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec Map vNumber Term
vs =
       Word -> Encoding
CBOR.encodeMapLen (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall k a. Map k a -> Int
Map.size Map vNumber Term
vs))
    forall a. Semigroup a => a -> a -> a
<> forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey
        (\vNumber
vNumber Term
vParams ->
            Term -> Encoding
CBOR.encodeTerm (forall fail a. CodecCBORTerm fail a -> a -> Term
encodeTerm CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec vNumber
vNumber)
         forall a. Semigroup a => a -> a -> a
<> Term -> Encoding
CBOR.encodeTerm Term
vParams
        )
        Map vNumber Term
vs


-- | 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.
--
decodeVersions :: forall vNumber failure s.
                  Ord vNumber
               => CodecCBORTerm (failure, Maybe Int) vNumber
               -> Int
               -> CBOR.Decoder s (Map vNumber CBOR.Term)
decodeVersions :: forall vNumber failure s.
Ord vNumber =>
CodecCBORTerm (failure, Maybe Int) vNumber
-> Int -> Decoder s (Map vNumber Term)
decodeVersions CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec Int
size = Int
-> Maybe vNumber
-> [(vNumber, Term)]
-> Decoder s (Map vNumber Term)
go Int
size forall a. Maybe a
Nothing []
  where
    go :: Int
       -> Maybe vNumber
       -> [(vNumber, CBOR.Term)]
       -> CBOR.Decoder s (Map vNumber CBOR.Term)
    go :: Int
-> Maybe vNumber
-> [(vNumber, Term)]
-> Decoder s (Map vNumber Term)
go Int
0  Maybe vNumber
_     ![(vNumber, Term)]
vs = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [(vNumber, Term)]
vs
    go !Int
l !Maybe vNumber
prev ![(vNumber, Term)]
vs = do
      Term
vNumberTerm <- forall s. Decoder s Term
CBOR.decodeTerm
      Term
vParams <- forall s. Decoder s Term
CBOR.decodeTerm
      case forall fail a. CodecCBORTerm fail a -> Term -> Either fail a
decodeTerm CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec Term
vNumberTerm of
        -- error when decoding un-recognized version; skip the version
        -- TODO: include error in the dictionary
        Left (failure, Maybe Int)
_        -> Int
-> Maybe vNumber
-> [(vNumber, Term)]
-> Decoder s (Map vNumber Term)
go (forall a. Enum a => a -> a
pred Int
l) Maybe vNumber
prev [(vNumber, Term)]
vs

        Right vNumber
vNumber -> do
          let next :: Maybe vNumber
next = forall a. a -> Maybe a
Just vNumber
vNumber
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe vNumber
next forall a. Ord a => a -> a -> Bool
> Maybe vNumber
prev)
            forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"codecHandshake.Propose: unordered version"
          Int
-> Maybe vNumber
-> [(vNumber, Term)]
-> Decoder s (Map vNumber Term)
go (forall a. Enum a => a -> a
pred Int
l) Maybe vNumber
next ((vNumber
vNumber, Term
vParams) forall a. a -> [a] -> [a]
: [(vNumber, Term)]
vs)


encodeRefuseReason :: CodecCBORTerm fail vNumber
                   -> RefuseReason vNumber
                   -> CBOR.Encoding
encodeRefuseReason :: forall fail vNumber.
CodecCBORTerm fail vNumber -> RefuseReason vNumber -> Encoding
encodeRefuseReason CodecCBORTerm fail vNumber
versionNumberCodec (VersionMismatch [vNumber]
vs [Int]
_) =
         Word -> Encoding
CBOR.encodeListLen Word
2
      forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
0
      forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeListLen (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [vNumber]
vs)
      forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Term -> Encoding
CBOR.encodeTerm forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall fail a. CodecCBORTerm fail a -> a -> Term
encodeTerm CodecCBORTerm fail vNumber
versionNumberCodec) [vNumber]
vs
encodeRefuseReason CodecCBORTerm fail vNumber
versionNumberCodec (HandshakeDecodeError vNumber
vNumber Text
vError) =
         Word -> Encoding
CBOR.encodeListLen Word
3
      forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
1
      forall a. Semigroup a => a -> a -> a
<> Term -> Encoding
CBOR.encodeTerm (forall fail a. CodecCBORTerm fail a -> a -> Term
encodeTerm CodecCBORTerm fail vNumber
versionNumberCodec vNumber
vNumber)
      forall a. Semigroup a => a -> a -> a
<> Text -> Encoding
CBOR.encodeString Text
vError
encodeRefuseReason CodecCBORTerm fail vNumber
versionNumberCodec (Refused vNumber
vNumber Text
vReason) =
         Word -> Encoding
CBOR.encodeListLen Word
3
      forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
2
      forall a. Semigroup a => a -> a -> a
<> Term -> Encoding
CBOR.encodeTerm (forall fail a. CodecCBORTerm fail a -> a -> Term
encodeTerm CodecCBORTerm fail vNumber
versionNumberCodec vNumber
vNumber)
      forall a. Semigroup a => a -> a -> a
<> Text -> Encoding
CBOR.encodeString Text
vReason


decodeRefuseReason :: Show failure
                   => CodecCBORTerm (failure, Maybe Int) vNumber
                   -> CBOR.Decoder s (RefuseReason vNumber)
decodeRefuseReason :: forall failure vNumber s.
Show failure =>
CodecCBORTerm (failure, Maybe Int) vNumber
-> Decoder s (RefuseReason vNumber)
decodeRefuseReason CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec = do
    Int
_ <- forall s. Decoder s Int
CBOR.decodeListLen
    Word
tag <- forall s. Decoder s Word
CBOR.decodeWord
    case Word
tag of
      Word
0 -> do
        Int
len <- forall s. Decoder s Int
CBOR.decodeListLen
        [Either (failure, Maybe Int) vNumber]
rs <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
len
                (forall fail a. CodecCBORTerm fail a -> Term -> Either fail a
decodeTerm CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Term
CBOR.decodeTerm)
        case forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (failure, Maybe Int) vNumber]
rs of
          ([(failure, Maybe Int)]
errs, [vNumber]
vNumbers) ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall vNumber. [vNumber] -> [Int] -> RefuseReason vNumber
VersionMismatch [vNumber]
vNumbers (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a, b) -> b
snd [(failure, Maybe Int)]
errs)
      Word
1 -> do
        Either (failure, Maybe Int) vNumber
v <- forall fail a. CodecCBORTerm fail a -> Term -> Either fail a
decodeTerm CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Term
CBOR.decodeTerm
        case Either (failure, Maybe Int) vNumber
v of
          Left (failure, Maybe Int)
e        -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"decode HandshakeDecodeError: unknow version: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (failure, Maybe Int)
e
          Right vNumber
vNumber -> forall vNumber. vNumber -> Text -> RefuseReason vNumber
HandshakeDecodeError vNumber
vNumber forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Text
CBOR.decodeString
      Word
2 -> do
        Either (failure, Maybe Int) vNumber
v <- forall fail a. CodecCBORTerm fail a -> Term -> Either fail a
decodeTerm CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Term
CBOR.decodeTerm
        case Either (failure, Maybe Int) vNumber
v of
          Left (failure, Maybe Int)
e        -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"decode Refused: unknonwn version: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (failure, Maybe Int)
e
          Right vNumber
vNumber -> forall vNumber. vNumber -> Text -> RefuseReason vNumber
Refused vNumber
vNumber forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Text
CBOR.decodeString
      Word
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"decode RefuseReason: unknown tag " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word
tag


-- | 'Handshake' codec for the @node-to-node@ protocol suite.
--
nodeToNodeHandshakeCodec :: MonadST m
                         => Codec (Handshake NodeToNodeVersion CBOR.Term)
                                  CBOR.DeserialiseFailure m BL.ByteString
nodeToNodeHandshakeCodec :: forall (m :: * -> *).
MonadST m =>
Codec
  (Handshake NodeToNodeVersion Term) DeserialiseFailure m ByteString
nodeToNodeHandshakeCodec = forall vNumber (m :: * -> *) failure.
(MonadST m, Ord vNumber, Show failure) =>
CodecCBORTerm (failure, Maybe Int) vNumber
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
codecHandshake CodecCBORTerm (Text, Maybe Int) NodeToNodeVersion
nodeToNodeVersionCodec


-- | 'Handshake' codec for the @node-to-client@ protocol suite.
--
nodeToClientHandshakeCodec :: MonadST m
                           => Codec (Handshake NodeToClientVersion CBOR.Term)
                                    CBOR.DeserialiseFailure m BL.ByteString
nodeToClientHandshakeCodec :: forall (m :: * -> *).
MonadST m =>
Codec
  (Handshake NodeToClientVersion Term)
  DeserialiseFailure
  m
  ByteString
nodeToClientHandshakeCodec = forall vNumber (m :: * -> *) failure.
(MonadST m, Ord vNumber, Show failure) =>
CodecCBORTerm (failure, Maybe Int) vNumber
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
codecHandshake CodecCBORTerm (Text, Maybe Int) NodeToClientVersion
nodeToClientVersionCodec