{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

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 Data.ByteString.Lazy qualified as BL
import Data.Either (partitionEithers)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import Text.Printf

import Network.TypedProtocol.Codec.CBOR
import Network.TypedProtocol.Core

import Codec.CBOR.Decoding qualified as CBOR
import Codec.CBOR.Encoding qualified as CBOR
import Codec.CBOR.Read qualified as CBOR
import Codec.CBOR.Term qualified 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 = CodecCBORTerm Text vData -> vData -> Term
forall fail a. CodecCBORTerm fail a -> a -> Term
encodeTerm (CodecCBORTerm Text vData -> vData -> Term)
-> (vNumber -> CodecCBORTerm Text vData)
-> vNumber
-> vData
-> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. vNumber -> CodecCBORTerm Text vData
codec,
      decodeData :: vNumber -> Term -> Either Text vData
decodeData = CodecCBORTerm Text vData -> Term -> Either Text vData
forall fail a. CodecCBORTerm fail a -> Term -> Either fail a
decodeTerm (CodecCBORTerm Text vData -> Term -> Either Text vData)
-> (vNumber -> CodecCBORTerm Text vData)
-> vNumber
-> Term
-> Either Text vData
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 Word -> Word -> Word
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 (st :: Handshake vNumber Term).
 ActiveState st =>
 StateToken st -> Word)
-> (ByteString -> Word)
-> ProtocolSizeLimits (Handshake vNumber Term) ByteString
forall ps bytes.
(forall (st :: ps). ActiveState st => StateToken st -> Word)
-> (bytes -> Word) -> ProtocolSizeLimits ps bytes
ProtocolSizeLimits StateToken st -> Word
forall (st :: Handshake vNumber Term).
ActiveState st =>
StateToken st -> Word
stateToLimit (Int64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word) -> (ByteString -> Int64) -> ByteString -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length)
  where
    stateToLimit :: forall (st  :: Handshake vNumber CBOR.Term).
                    ActiveState st
                 => StateToken st -> Word
    stateToLimit :: forall (st :: Handshake vNumber Term).
ActiveState st =>
StateToken st -> Word
stateToLimit StateToken st
SingHandshake st
SingPropose =
      Word
maxTransmissionUnit
    stateToLimit StateToken st
SingHandshake st
SingConfirm =
      Word
maxTransmissionUnit
    stateToLimit a :: StateToken st
a@StateToken st
SingHandshake st
SingDone = StateToken 'StDone -> forall a. a
forall ps (st :: ps).
(StateAgency st ~ 'NobodyAgency, ActiveState st) =>
StateToken st -> forall a. a
notActiveState StateToken st
StateToken 'StDone
a

-- | Time limits.
--
timeLimitsHandshake :: forall vNumber. ProtocolTimeLimits (Handshake vNumber CBOR.Term)
timeLimitsHandshake :: forall {k} (vNumber :: k).
ProtocolTimeLimits (Handshake vNumber Term)
timeLimitsHandshake = (forall (st :: Handshake vNumber Term).
 ActiveState st =>
 StateToken st -> Maybe DiffTime)
-> ProtocolTimeLimits (Handshake vNumber Term)
forall ps.
(forall (st :: ps).
 ActiveState st =>
 StateToken st -> Maybe DiffTime)
-> ProtocolTimeLimits ps
ProtocolTimeLimits StateToken st -> Maybe DiffTime
forall (st :: Handshake vNumber Term).
ActiveState st =>
StateToken st -> Maybe DiffTime
stateToLimit
  where
    stateToLimit :: forall (st  :: Handshake vNumber CBOR.Term).
                    ActiveState st
                 => StateToken st -> Maybe DiffTime
    stateToLimit :: forall (st :: Handshake vNumber Term).
ActiveState st =>
StateToken st -> Maybe DiffTime
stateToLimit StateToken st
SingHandshake st
SingPropose = Maybe DiffTime
shortWait
    stateToLimit StateToken st
SingHandshake st
SingConfirm = Maybe DiffTime
shortWait
    stateToLimit a :: StateToken st
a@StateToken st
SingHandshake st
SingDone  = StateToken 'StDone -> forall a. a
forall ps (st :: ps).
(StateAgency st ~ 'NobodyAgency, ActiveState st) =>
StateToken st -> forall a. a
notActiveState StateToken st
StateToken 'StDone
a


noTimeLimitsHandshake :: forall vNumber. ProtocolTimeLimits (Handshake vNumber CBOR.Term)
noTimeLimitsHandshake :: forall {k} (vNumber :: k).
ProtocolTimeLimits (Handshake vNumber Term)
noTimeLimitsHandshake = (forall (st :: Handshake vNumber Term).
 ActiveState st =>
 StateToken st -> Maybe DiffTime)
-> ProtocolTimeLimits (Handshake vNumber Term)
forall ps.
(forall (st :: ps).
 ActiveState st =>
 StateToken st -> Maybe DiffTime)
-> ProtocolTimeLimits ps
ProtocolTimeLimits StateToken st -> Maybe DiffTime
forall (st :: Handshake vNumber Term).
ActiveState st =>
StateToken st -> Maybe DiffTime
stateToLimit
  where
    stateToLimit :: forall (st  :: Handshake vNumber CBOR.Term).
                    ActiveState st
                 => StateToken st -> Maybe DiffTime
    stateToLimit :: forall (st :: Handshake vNumber Term).
ActiveState st =>
StateToken st -> Maybe DiffTime
stateToLimit StateToken st
SingHandshake st
SingPropose = Maybe DiffTime
forall a. Maybe a
Nothing
    stateToLimit StateToken st
SingHandshake st
SingConfirm = Maybe DiffTime
forall a. Maybe a
Nothing
    stateToLimit a :: StateToken st
a@StateToken st
SingHandshake st
SingDone  = StateToken 'StDone -> forall a. a
forall ps (st :: ps).
(StateAgency st ~ 'NobodyAgency, ActiveState st) =>
StateToken st -> forall a. a
notActiveState StateToken st
StateToken 'StDone
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 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 (st :: Handshake vNumber Term)
        (st' :: Handshake vNumber Term).
 (StateTokenI st, ActiveState st) =>
 Message (Handshake vNumber Term) st st' -> Encoding)
-> (forall (st :: Handshake vNumber Term) s.
    ActiveState st =>
    StateToken st -> Decoder s (SomeMessage st))
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
forall ps (m :: * -> *).
MonadST m =>
(forall (st :: ps) (st' :: ps).
 (StateTokenI st, ActiveState st) =>
 Message ps st st' -> Encoding)
-> (forall (st :: ps) s.
    ActiveState st =>
    StateToken st -> Decoder s (SomeMessage st))
-> Codec ps DeserialiseFailure m ByteString
mkCodecCborLazyBS Message (Handshake vNumber Term) st st' -> Encoding
forall (st :: Handshake vNumber Term)
       (st' :: Handshake vNumber Term).
Message (Handshake vNumber Term) st st' -> Encoding
forall (st :: Handshake vNumber Term)
       (st' :: Handshake vNumber Term).
(StateTokenI st, ActiveState st) =>
Message (Handshake vNumber Term) st st' -> Encoding
encodeMsg StateToken st -> Decoder s (SomeMessage st)
forall s (st :: Handshake vNumber Term).
ActiveState st =>
StateToken st -> Decoder s (SomeMessage st)
forall (st :: Handshake vNumber Term) s.
ActiveState st =>
StateToken st -> Decoder s (SomeMessage st)
decodeMsg
    where
      encodeMsg
        :: forall st st'.
           Message (Handshake vNumber CBOR.Term) st st'
        -> CBOR.Encoding

      encodeMsg :: forall (st :: Handshake vNumber Term)
       (st' :: Handshake vNumber Term).
Message (Handshake vNumber Term) st st' -> Encoding
encodeMsg (MsgProposeVersions Map vNumber1 vParams1
vs) =
           Word -> Encoding
CBOR.encodeListLen Word
2
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
0
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CodecCBORTerm (failure, Maybe Int) vNumber
-> Map vNumber Term -> Encoding
forall failure vNumber.
CodecCBORTerm (failure, Maybe Int) vNumber
-> Map vNumber Term -> Encoding
encodeVersions CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec Map vNumber Term
Map vNumber1 vParams1
vs

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

      encodeMsg (MsgAcceptVersion vNumber1
vNumber vParams1
vParams) =
           Word -> Encoding
CBOR.encodeListLen Word
3
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
1
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Term -> Encoding
CBOR.encodeTerm (CodecCBORTerm (failure, Maybe Int) vNumber -> vNumber -> Term
forall fail a. CodecCBORTerm fail a -> a -> Term
encodeTerm CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec vNumber
vNumber1
vNumber)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Term -> Encoding
CBOR.encodeTerm vParams1
Term
vParams

      encodeMsg (MsgRefuse RefuseReason vNumber1
vReason) =
           Word -> Encoding
CBOR.encodeListLen Word
2
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
2
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CodecCBORTerm (failure, Maybe Int) vNumber
-> RefuseReason vNumber -> Encoding
forall fail vNumber.
CodecCBORTerm fail vNumber -> RefuseReason vNumber -> Encoding
encodeRefuseReason CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec RefuseReason vNumber
RefuseReason vNumber1
vReason

      encodeMsg (MsgQueryReply Map vNumber1 vParams1
vs) =
           Word -> Encoding
CBOR.encodeListLen Word
2
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
3
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CodecCBORTerm (failure, Maybe Int) vNumber
-> Map vNumber Term -> Encoding
forall failure vNumber.
CodecCBORTerm (failure, Maybe Int) vNumber
-> Map vNumber Term -> Encoding
encodeVersions CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec Map vNumber Term
Map vNumber1 vParams1
vs

      decodeMsg :: forall s (st :: Handshake vNumber CBOR.Term).
                   ActiveState st
                => StateToken st
                -> CBOR.Decoder s (SomeMessage st)
      decodeMsg :: forall s (st :: Handshake vNumber Term).
ActiveState st =>
StateToken st -> Decoder s (SomeMessage st)
decodeMsg StateToken st
stok = do
        len <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeListLen
        key <- CBOR.decodeWord
        case (stok, key, len) of
          (SingHandshake st
SingPropose, Word
0, Int
2) -> do
            l  <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeMapLen
            vMap <- decodeVersions versionNumberCodec l
            pure $ SomeMessage $ MsgProposeVersions vMap
          (SingHandshake st
SingConfirm, Word
0, Int
2) -> do
            l  <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeMapLen
            vMap <- decodeVersions versionNumberCodec l
            pure $ SomeMessage $ MsgReplyVersions vMap
          (SingHandshake st
SingConfirm, Word
1, Int
3) -> do
            v <- CodecCBORTerm (failure, Maybe Int) vNumber
-> Term -> Either (failure, Maybe Int) vNumber
forall fail a. CodecCBORTerm fail a -> Term -> Either fail a
decodeTerm CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec (Term -> Either (failure, Maybe Int) vNumber)
-> Decoder s Term
-> Decoder s (Either (failure, Maybe Int) vNumber)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Term
forall s. Decoder s Term
CBOR.decodeTerm
            case 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 -> String -> Decoder s (SomeMessage st)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"codecHandshake.MsgAcceptVersion: not recognized version: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (failure, Maybe Int) -> String
forall a. Show a => a -> String
show (failure, Maybe Int)
e)
              Right vNumber
vNumber ->
                Message (Handshake vNumber Term) st 'StDone -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage (Message (Handshake vNumber Term) st 'StDone -> SomeMessage st)
-> (Term -> Message (Handshake vNumber Term) st 'StDone)
-> Term
-> SomeMessage st
forall b c a. (b -> c) -> (a -> b) -> a -> c
. vNumber
-> Term -> Message (Handshake vNumber Term) 'StConfirm 'StDone
forall vNumber1 vParams1.
vNumber1
-> vParams1
-> Message (Handshake vNumber1 vParams1) 'StConfirm 'StDone
MsgAcceptVersion vNumber
vNumber (Term -> SomeMessage st)
-> Decoder s Term -> Decoder s (SomeMessage st)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Term
forall s. Decoder s Term
CBOR.decodeTerm
          (SingHandshake st
SingConfirm, Word
2, Int
2) ->
            Message (Handshake vNumber Term) st 'StDone -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage (Message (Handshake vNumber Term) st 'StDone -> SomeMessage st)
-> (RefuseReason vNumber
    -> Message (Handshake vNumber Term) st 'StDone)
-> RefuseReason vNumber
-> SomeMessage st
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RefuseReason vNumber -> Message (Handshake vNumber Term) st 'StDone
RefuseReason vNumber
-> Message (Handshake vNumber Term) 'StConfirm 'StDone
forall {k1} vNumber1 (vParams :: k1).
RefuseReason vNumber1
-> Message (Handshake vNumber1 vParams) 'StConfirm 'StDone
MsgRefuse (RefuseReason vNumber -> SomeMessage st)
-> Decoder s (RefuseReason vNumber) -> Decoder s (SomeMessage st)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CodecCBORTerm (failure, Maybe Int) vNumber
-> Decoder s (RefuseReason vNumber)
forall failure vNumber s.
Show failure =>
CodecCBORTerm (failure, Maybe Int) vNumber
-> Decoder s (RefuseReason vNumber)
decodeRefuseReason CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec
          (SingHandshake st
SingConfirm, Word
3, Int
2) -> do
            l  <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeMapLen
            vMap <- decodeVersions versionNumberCodec l
            pure $ SomeMessage $ MsgQueryReply vMap

          (SingHandshake st
SingPropose, Word
_, Int
_) ->
            String -> Decoder s (SomeMessage st)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s (SomeMessage st))
-> String -> Decoder s (SomeMessage st)
forall a b. (a -> b) -> a -> b
$ String -> String -> Word -> Int -> String
forall r. PrintfType r => String -> r
printf String
"codecHandshake (%s) unexpected key (%d, %d)" (SingHandshake 'StPropose -> String
forall a. Show a => a -> String
show StateToken st
SingHandshake 'StPropose
stok) Word
key Int
len
          (SingHandshake st
SingConfirm, Word
_, Int
_) ->
            String -> Decoder s (SomeMessage st)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s (SomeMessage st))
-> String -> Decoder s (SomeMessage st)
forall a b. (a -> b) -> a -> b
$ String -> String -> Word -> Int -> String
forall r. PrintfType r => String -> r
printf String
"codecHandshake (%s) unexpected key (%d, %d)" (SingHandshake 'StConfirm -> String
forall a. Show a => a -> String
show StateToken st
SingHandshake 'StConfirm
stok) Word
key Int
len
          (SingHandshake st
SingDone, Word
_, Int
_) -> StateToken 'StDone -> forall a. a
forall ps (st :: ps).
(StateAgency st ~ 'NobodyAgency, ActiveState st) =>
StateToken st -> forall a. a
notActiveState StateToken st
StateToken 'StDone
stok


-- | 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 (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Map vNumber Term -> Int
forall k a. Map k a -> Int
Map.size Map vNumber Term
vs))
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> (vNumber -> Term -> Encoding) -> Map vNumber Term -> Encoding
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey
        (\vNumber
vNumber Term
vParams ->
            Term -> Encoding
CBOR.encodeTerm (CodecCBORTerm (failure, Maybe Int) vNumber -> vNumber -> Term
forall fail a. CodecCBORTerm fail a -> a -> Term
encodeTerm CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec vNumber
vNumber)
         Encoding -> Encoding -> Encoding
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 Maybe vNumber
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 = Map vNumber Term -> Decoder s (Map vNumber Term)
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map vNumber Term -> Decoder s (Map vNumber Term))
-> Map vNumber Term -> Decoder s (Map vNumber Term)
forall a b. (a -> b) -> a -> b
$ [(vNumber, Term)] -> Map vNumber Term
forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList ([(vNumber, Term)] -> Map vNumber Term)
-> [(vNumber, Term)] -> Map vNumber Term
forall a b. (a -> b) -> a -> b
$ [(vNumber, Term)] -> [(vNumber, Term)]
forall a. [a] -> [a]
reverse [(vNumber, Term)]
vs
    go !Int
l !Maybe vNumber
prev ![(vNumber, Term)]
vs = do
      vNumberTerm <- Decoder s Term
forall s. Decoder s Term
CBOR.decodeTerm
      vParams <- CBOR.decodeTerm
      case decodeTerm versionNumberCodec 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 (Int -> Int
forall a. Enum a => a -> a
pred Int
l) Maybe vNumber
prev [(vNumber, Term)]
vs

        Right vNumber
vNumber -> do
          let next :: Maybe vNumber
next = vNumber -> Maybe vNumber
forall a. a -> Maybe a
Just vNumber
vNumber
          Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe vNumber
next Maybe vNumber -> Maybe vNumber -> Bool
forall a. Ord a => a -> a -> Bool
> Maybe vNumber
prev)
            (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$ String -> Decoder s ()
forall a. String -> Decoder s a
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 (Int -> Int
forall a. Enum a => a -> a
pred Int
l) Maybe vNumber
next ((vNumber
vNumber, Term
vParams) (vNumber, Term) -> [(vNumber, Term)] -> [(vNumber, Term)]
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
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
0
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeListLen (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ [vNumber] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [vNumber]
vs)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> (vNumber -> Encoding) -> [vNumber] -> Encoding
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Term -> Encoding
CBOR.encodeTerm (Term -> Encoding) -> (vNumber -> Term) -> vNumber -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodecCBORTerm fail vNumber -> vNumber -> Term
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
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
1
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Term -> Encoding
CBOR.encodeTerm (CodecCBORTerm fail vNumber -> vNumber -> Term
forall fail a. CodecCBORTerm fail a -> a -> Term
encodeTerm CodecCBORTerm fail vNumber
versionNumberCodec vNumber
vNumber)
      Encoding -> Encoding -> Encoding
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
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
2
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Term -> Encoding
CBOR.encodeTerm (CodecCBORTerm fail vNumber -> vNumber -> Term
forall fail a. CodecCBORTerm fail a -> a -> Term
encodeTerm CodecCBORTerm fail vNumber
versionNumberCodec vNumber
vNumber)
      Encoding -> Encoding -> Encoding
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
    _ <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeListLen
    tag <- CBOR.decodeWord
    case tag of
      Word
0 -> do
        len <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeListLen
        rs <- replicateM len
                (decodeTerm versionNumberCodec <$> CBOR.decodeTerm)
        case partitionEithers rs of
          ([(failure, Maybe Int)]
errs, [vNumber]
vNumbers) ->
            RefuseReason vNumber -> Decoder s (RefuseReason vNumber)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RefuseReason vNumber -> Decoder s (RefuseReason vNumber))
-> RefuseReason vNumber -> Decoder s (RefuseReason vNumber)
forall a b. (a -> b) -> a -> b
$ [vNumber] -> [Int] -> RefuseReason vNumber
forall vNumber. [vNumber] -> [Int] -> RefuseReason vNumber
VersionMismatch [vNumber]
vNumbers (((failure, Maybe Int) -> Maybe Int)
-> [(failure, Maybe Int)] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (failure, Maybe Int) -> Maybe Int
forall a b. (a, b) -> b
snd [(failure, Maybe Int)]
errs)
      Word
1 -> do
        v <- CodecCBORTerm (failure, Maybe Int) vNumber
-> Term -> Either (failure, Maybe Int) vNumber
forall fail a. CodecCBORTerm fail a -> Term -> Either fail a
decodeTerm CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec (Term -> Either (failure, Maybe Int) vNumber)
-> Decoder s Term
-> Decoder s (Either (failure, Maybe Int) vNumber)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Term
forall s. Decoder s Term
CBOR.decodeTerm
        case v of
          Left (failure, Maybe Int)
e        -> String -> Decoder s (RefuseReason vNumber)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s (RefuseReason vNumber))
-> String -> Decoder s (RefuseReason vNumber)
forall a b. (a -> b) -> a -> b
$ String
"decode HandshakeDecodeError: unknow version: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (failure, Maybe Int) -> String
forall a. Show a => a -> String
show (failure, Maybe Int)
e
          Right vNumber
vNumber -> vNumber -> Text -> RefuseReason vNumber
forall vNumber. vNumber -> Text -> RefuseReason vNumber
HandshakeDecodeError vNumber
vNumber (Text -> RefuseReason vNumber)
-> Decoder s Text -> Decoder s (RefuseReason vNumber)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Text
forall s. Decoder s Text
CBOR.decodeString
      Word
2 -> do
        v <- CodecCBORTerm (failure, Maybe Int) vNumber
-> Term -> Either (failure, Maybe Int) vNumber
forall fail a. CodecCBORTerm fail a -> Term -> Either fail a
decodeTerm CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec (Term -> Either (failure, Maybe Int) vNumber)
-> Decoder s Term
-> Decoder s (Either (failure, Maybe Int) vNumber)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Term
forall s. Decoder s Term
CBOR.decodeTerm
        case v of
          Left (failure, Maybe Int)
e        -> String -> Decoder s (RefuseReason vNumber)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s (RefuseReason vNumber))
-> String -> Decoder s (RefuseReason vNumber)
forall a b. (a -> b) -> a -> b
$ String
"decode Refused: unknonwn version: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (failure, Maybe Int) -> String
forall a. Show a => a -> String
show (failure, Maybe Int)
e
          Right vNumber
vNumber -> vNumber -> Text -> RefuseReason vNumber
forall vNumber. vNumber -> Text -> RefuseReason vNumber
Refused vNumber
vNumber (Text -> RefuseReason vNumber)
-> Decoder s Text -> Decoder s (RefuseReason vNumber)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Text
forall s. Decoder s Text
CBOR.decodeString
      Word
_ -> String -> Decoder s (RefuseReason vNumber)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s (RefuseReason vNumber))
-> String -> Decoder s (RefuseReason vNumber)
forall a b. (a -> b) -> a -> b
$ String
"decode RefuseReason: unknown tag " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word -> String
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 = CodecCBORTerm (Text, Maybe Int) NodeToNodeVersion
-> Codec
     (Handshake NodeToNodeVersion Term) DeserialiseFailure m ByteString
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 = CodecCBORTerm (Text, Maybe Int) NodeToClientVersion
-> Codec
     (Handshake NodeToClientVersion Term)
     DeserialiseFailure
     m
     ByteString
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