{-# 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
  ) where

import           Control.Monad (replicateM, unless)
import           Control.Monad.Class.MonadST
import           Control.Monad.Class.MonadTime
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

-- | 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 {
    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).
    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 :: (vNumber -> CodecCBORTerm Text vData)
-> VersionDataCodec Term vNumber vData
cborTermVersionDataCodec vNumber -> CodecCBORTerm Text vData
codec = VersionDataCodec :: forall bytes vNumber vData.
(vNumber -> vData -> bytes)
-> (vNumber -> bytes -> Either Text vData)
-> VersionDataCodec bytes vNumber vData
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 :: ProtocolSizeLimits (Handshake vNumber Term) ByteString
byteLimitsHandshake = (forall (pr :: PeerRole) (st :: Handshake vNumber Term).
 PeerHasAgency pr st -> Word)
-> (ByteString -> Word)
-> ProtocolSizeLimits (Handshake vNumber Term) ByteString
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 (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 (pr :: PeerRole) (st  :: Handshake vNumber CBOR.Term).
                    PeerHasAgency pr st -> Word
    stateToLimit :: PeerHasAgency pr st -> Word
stateToLimit (ClientAgency ClientHasAgency st
TokPropose) = Word
maxTransmissionUnit
    stateToLimit (ServerAgency ServerHasAgency st
TokConfirm) = Word
maxTransmissionUnit

-- | Time limits.
--
timeLimitsHandshake :: forall vNumber. ProtocolTimeLimits (Handshake vNumber CBOR.Term)
timeLimitsHandshake :: ProtocolTimeLimits (Handshake vNumber Term)
timeLimitsHandshake = (forall (pr :: PeerRole) (st :: Handshake vNumber Term).
 PeerHasAgency pr st -> Maybe DiffTime)
-> ProtocolTimeLimits (Handshake vNumber Term)
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 :: PeerHasAgency pr st -> Maybe DiffTime
stateToLimit (ClientAgency ClientHasAgency st
TokPropose) = Maybe DiffTime
shortWait
    stateToLimit (ServerAgency ServerHasAgency st
TokConfirm) = Maybe DiffTime
shortWait


noTimeLimitsHandshake :: forall vNumber. ProtocolTimeLimits (Handshake vNumber CBOR.Term)
noTimeLimitsHandshake :: ProtocolTimeLimits (Handshake vNumber Term)
noTimeLimitsHandshake = (forall (pr :: PeerRole) (st :: Handshake vNumber Term).
 PeerHasAgency pr st -> Maybe DiffTime)
-> ProtocolTimeLimits (Handshake vNumber Term)
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 :: PeerHasAgency pr st -> Maybe DiffTime
stateToLimit (ClientAgency ClientHasAgency st
TokPropose) = Maybe DiffTime
forall a. Maybe a
Nothing
    stateToLimit (ServerAgency ServerHasAgency st
TokConfirm) = Maybe DiffTime
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 :: CodecCBORTerm (failure, Maybe Int) vNumber
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
codecHandshake CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec = (forall (pr :: PeerRole) (st :: Handshake vNumber Term)
        (st' :: Handshake vNumber Term).
 PeerHasAgency pr st
 -> Message (Handshake vNumber Term) st st' -> Encoding)
-> (forall (pr :: PeerRole) (st :: Handshake vNumber Term) s.
    PeerHasAgency pr st -> Decoder s (SomeMessage st))
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
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)
forall (pr :: PeerRole) (st :: Handshake vNumber Term) s.
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 :: PeerHasAgency pr st
-> Message (Handshake vNumber Term) st st' -> Encoding
encodeMsg (ClientAgency ClientHasAgency st
TokPropose) (MsgProposeVersions 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 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
TokConfirm) (MsgReplyVersions 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 vNumber vParams
vs

      encodeMsg (ServerAgency ServerHasAgency st
TokConfirm) (MsgAcceptVersion vNumber 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
vNumber
vNumber)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Term -> Encoding
CBOR.encodeTerm vParams
Term
vParams

      encodeMsg (ServerAgency ServerHasAgency st
TokConfirm) (MsgRefuse 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 vNumber
vReason

      decodeMsg :: forall (pr :: PeerRole) s (st :: Handshake vNumber CBOR.Term).
                   PeerHasAgency pr st
                -> CBOR.Decoder s (SomeMessage st)
      decodeMsg :: PeerHasAgency pr st -> Decoder s (SomeMessage st)
decodeMsg PeerHasAgency pr st
stok = do
        Int
len <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeListLen
        Word
key <- Decoder s Word
forall s. Decoder s Word
CBOR.decodeWord
        case (PeerHasAgency pr st
stok, Word
key, Int
len) of
          (ClientAgency ClientHasAgency st
TokPropose, Word
0, Int
2) -> do
            Int
l  <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeMapLen
            Map vNumber Term
vMap <- CodecCBORTerm (failure, Maybe Int) vNumber
-> Int -> Decoder s (Map vNumber Term)
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
            SomeMessage 'StPropose -> Decoder s (SomeMessage 'StPropose)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeMessage 'StPropose -> Decoder s (SomeMessage 'StPropose))
-> SomeMessage 'StPropose -> Decoder s (SomeMessage 'StPropose)
forall a b. (a -> b) -> a -> b
$ Message (Handshake vNumber Term) 'StPropose 'StConfirm
-> SomeMessage 'StPropose
forall ps (st :: ps) (st' :: ps).
Message ps st st' -> SomeMessage st
SomeMessage (Message (Handshake vNumber Term) 'StPropose 'StConfirm
 -> SomeMessage 'StPropose)
-> Message (Handshake vNumber Term) 'StPropose 'StConfirm
-> SomeMessage 'StPropose
forall a b. (a -> b) -> a -> b
$ Map vNumber Term
-> Message (Handshake vNumber Term) 'StPropose 'StConfirm
forall vNumber vNumber.
Map vNumber vNumber
-> Message (Handshake vNumber vNumber) 'StPropose 'StConfirm
MsgProposeVersions Map vNumber Term
vMap
          (ServerAgency ServerHasAgency st
TokConfirm, Word
0, Int
2) -> do
            Int
l  <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeMapLen
            Map vNumber Term
vMap <- CodecCBORTerm (failure, Maybe Int) vNumber
-> Int -> Decoder s (Map vNumber Term)
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
            SomeMessage 'StConfirm -> Decoder s (SomeMessage 'StConfirm)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeMessage 'StConfirm -> Decoder s (SomeMessage 'StConfirm))
-> SomeMessage 'StConfirm -> Decoder s (SomeMessage 'StConfirm)
forall a b. (a -> b) -> a -> b
$ Message (Handshake vNumber Term) 'StConfirm 'StDone
-> SomeMessage 'StConfirm
forall ps (st :: ps) (st' :: ps).
Message ps st st' -> SomeMessage st
SomeMessage (Message (Handshake vNumber Term) 'StConfirm 'StDone
 -> SomeMessage 'StConfirm)
-> Message (Handshake vNumber Term) 'StConfirm 'StDone
-> SomeMessage 'StConfirm
forall a b. (a -> b) -> a -> b
$ Map vNumber Term
-> Message (Handshake vNumber Term) 'StConfirm 'StDone
forall vNumber vNumber.
Map vNumber vNumber
-> Message (Handshake vNumber vNumber) 'StConfirm 'StDone
MsgReplyVersions Map vNumber Term
vMap
          (ServerAgency ServerHasAgency st
TokConfirm, Word
1, Int
3) -> do
            Either (failure, Maybe Int) vNumber
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 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 -> String -> Decoder s (SomeMessage st)
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) 'StConfirm 'StDone
-> SomeMessage 'StConfirm
forall ps (st :: ps) (st' :: ps).
Message ps st st' -> SomeMessage st
SomeMessage (Message (Handshake vNumber Term) 'StConfirm 'StDone
 -> SomeMessage 'StConfirm)
-> (Term -> Message (Handshake vNumber Term) 'StConfirm 'StDone)
-> Term
-> SomeMessage 'StConfirm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. vNumber
-> Term -> Message (Handshake vNumber Term) 'StConfirm 'StDone
forall vNumber vNumber.
vNumber
-> vNumber
-> Message (Handshake vNumber vNumber) 'StConfirm 'StDone
MsgAcceptVersion vNumber
vNumber (Term -> SomeMessage 'StConfirm)
-> Decoder s Term -> Decoder s (SomeMessage 'StConfirm)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Term
forall s. Decoder s Term
CBOR.decodeTerm
          (ServerAgency ServerHasAgency st
TokConfirm, Word
2, Int
2) ->
            Message (Handshake vNumber Term) 'StConfirm 'StDone
-> SomeMessage 'StConfirm
forall ps (st :: ps) (st' :: ps).
Message ps st st' -> SomeMessage st
SomeMessage (Message (Handshake vNumber Term) 'StConfirm 'StDone
 -> SomeMessage 'StConfirm)
-> (RefuseReason vNumber
    -> Message (Handshake vNumber Term) 'StConfirm 'StDone)
-> RefuseReason vNumber
-> SomeMessage 'StConfirm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RefuseReason vNumber
-> Message (Handshake vNumber Term) 'StConfirm 'StDone
forall k vNumber (vParams :: k).
RefuseReason vNumber
-> Message (Handshake vNumber vParams) 'StConfirm 'StDone
MsgRefuse (RefuseReason vNumber -> SomeMessage 'StConfirm)
-> Decoder s (RefuseReason vNumber)
-> Decoder s (SomeMessage 'StConfirm)
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

          (ClientAgency ClientHasAgency st
TokPropose, Word
_, Int
_) ->
            String -> Decoder s (SomeMessage st)
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)" (PeerHasAgency pr st -> String
forall a. Show a => a -> String
show PeerHasAgency pr st
stok) Word
key Int
len
          (ServerAgency ServerHasAgency st
TokConfirm, Word
_, Int
_) ->
            String -> Decoder s (SomeMessage st)
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)" (PeerHasAgency pr st -> String
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 :: 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 :: 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 (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
      Term
vNumberTerm <- Decoder s Term
forall s. Decoder s Term
CBOR.decodeTerm
      Term
vParams <- Decoder s Term
forall s. Decoder s Term
CBOR.decodeTerm
      case 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
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 (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 :: 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 (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 (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 :: CodecCBORTerm (failure, Maybe Int) vNumber
-> Decoder s (RefuseReason vNumber)
decodeRefuseReason CodecCBORTerm (failure, Maybe Int) vNumber
versionNumberCodec = do
    Int
_ <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeListLen
    Word
tag <- Decoder s Word
forall s. Decoder s Word
CBOR.decodeWord
    case Word
tag of
      Word
0 -> do
        Int
len <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeListLen
        [Either (failure, Maybe Int) vNumber]
rs <- Int
-> Decoder s (Either (failure, Maybe Int) vNumber)
-> Decoder s [Either (failure, Maybe Int) vNumber]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
len
                (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 [Either (failure, Maybe Int) vNumber]
-> ([(failure, Maybe Int)], [vNumber])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (failure, Maybe Int) vNumber]
rs of
          ([(failure, Maybe Int)]
errs, [vNumber]
vNumbers) ->
            RefuseReason vNumber -> Decoder s (RefuseReason vNumber)
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
        Either (failure, Maybe Int) vNumber
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 Either (failure, Maybe Int) vNumber
v of
          Left (failure, Maybe Int)
e        -> String -> Decoder s (RefuseReason vNumber)
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
        Either (failure, Maybe Int) vNumber
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 Either (failure, Maybe Int) vNumber
v of
          Left (failure, Maybe Int)
e        -> String -> Decoder s (RefuseReason vNumber)
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 (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