{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}

module Ouroboros.Network.Protocol.Handshake.Client
  ( handshakeClientPeer
  , handshakeClientPeerWithRTT
  , decodeQueryResult
  , encodeVersions
  , acceptOrRefuse
  ) where

import Control.Monad.Class.MonadTime.SI
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Text (Text)

import Codec.CBOR.Term qualified as CBOR

import Network.TypedProtocol.Peer.Client

import Ouroboros.Network.Protocol.Handshake.Codec
import Ouroboros.Network.Protocol.Handshake.Type
import Ouroboros.Network.Protocol.Handshake.Version

-- | Handshake client which offers @'Versions' vNumber vData@ to the
-- remote peer.
handshakeClientPeer
  :: ( Monad m
     , Ord vNumber
     )
  => VersionDataCodec vNumber vData
  -> (vData -> vData -> Accept vData)
  -> Versions vNumber vData r
  -> Client (Handshake vNumber CBOR.Term)
            NonPipelined StPropose m
            (Either
              (HandshakeProtocolError vNumber)
              (HandshakeResult r vNumber vData)
            )
handshakeClientPeer :: forall (m :: * -> *) vNumber vData r.
(Monad m, Ord vNumber) =>
VersionDataCodec vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData))
handshakeClientPeer VersionDataCodec vNumber vData
codec vData -> vData -> Accept vData
acceptVersion Versions vNumber vData r
versions =
  (Either
   (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
 ())
-> Either
     (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData)
forall a b. (a, b) -> a
fst ((Either
    (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
  ())
 -> Either
      (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData))
-> Peer
     (Handshake vNumber Term)
     'AsClient
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      ())
-> Peer
     (Handshake vNumber Term)
     'AsClient
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TimeAPI () () m
-> VersionDataCodec vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Peer
     (Handshake vNumber Term)
     'AsClient
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      ())
forall vNumber (m :: * -> *) time diffTime vData r.
(Ord vNumber, Monad m) =>
TimeAPI time diffTime m
-> VersionDataCodec vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      diffTime)
handshakeClientPeer' TimeAPI () () m
forall (m :: * -> *). Applicative m => TimeAPI () () m
nullTimeAPI
                               VersionDataCodec vNumber vData
codec vData -> vData -> Accept vData
acceptVersion Versions vNumber vData r
versions

-- | Handshake client which offers @'Versions' vNumber vData@ to the
-- remote peer and computes round trip time.
--
-- TODO: GADT encoding of the client (@Handshake.Client@ module).
--
handshakeClientPeerWithRTT
  :: ( Ord vNumber
     , MonadMonotonicTime m
     )
  => VersionDataCodec vNumber vData
  -> (vData -> vData -> Accept vData)
  -> Versions vNumber vData r
  -> Client (Handshake vNumber CBOR.Term)
            NonPipelined StPropose m
            ( Either
                (HandshakeProtocolError vNumber)
                (HandshakeResult r vNumber vData)
            , DiffTime
            )
     -- ^ the client which offers the versions, does the negotiation and
     -- provides round trip time

handshakeClientPeerWithRTT :: forall vNumber (m :: * -> *) vData r.
(Ord vNumber, MonadMonotonicTime m) =>
VersionDataCodec vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      DiffTime)
handshakeClientPeerWithRTT = TimeAPI Time DiffTime m
-> VersionDataCodec vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      DiffTime)
forall vNumber (m :: * -> *) time diffTime vData r.
(Ord vNumber, Monad m) =>
TimeAPI time diffTime m
-> VersionDataCodec vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      diffTime)
handshakeClientPeer' TimeAPI Time DiffTime m
forall (m :: * -> *).
MonadMonotonicTime m =>
TimeAPI Time DiffTime m
monotonicTimeAPI


data TimeAPI time diffTime m = TimeAPI {
    forall time diffTime (m :: * -> *).
TimeAPI time diffTime m -> m time
getTime  :: m time,
    forall time diffTime (m :: * -> *).
TimeAPI time diffTime m -> time -> time -> diffTime
timeDiff :: time -> time -> diffTime
 }

monotonicTimeAPI :: MonadMonotonicTime m => TimeAPI Time DiffTime m
monotonicTimeAPI :: forall (m :: * -> *).
MonadMonotonicTime m =>
TimeAPI Time DiffTime m
monotonicTimeAPI = TimeAPI {
    getTime :: m Time
getTime = m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime,
    timeDiff :: Time -> Time -> DiffTime
timeDiff = Time -> Time -> DiffTime
diffTime
  }

nullTimeAPI :: Applicative m => TimeAPI () () m
nullTimeAPI :: forall (m :: * -> *). Applicative m => TimeAPI () () m
nullTimeAPI = TimeAPI {
    getTime :: m ()
getTime  = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
    timeDiff :: () -> () -> ()
timeDiff = \() () -> ()
  }

-- | A generic handshake client.
--
handshakeClientPeer'
  :: ( Ord vNumber
     , Monad m
     )
  => TimeAPI time diffTime m
  -> VersionDataCodec vNumber vData
  -> (vData -> vData -> Accept vData)
  -> Versions vNumber vData r
  -> Client (Handshake vNumber CBOR.Term)
            NonPipelined StPropose m
            ( Either
                (HandshakeProtocolError vNumber)
                (HandshakeResult r vNumber vData)
            , diffTime
            )
     -- ^ the client which offers the versions, does the negotiation and
     -- provides round trip time
handshakeClientPeer' :: forall vNumber (m :: * -> *) time diffTime vData r.
(Ord vNumber, Monad m) =>
TimeAPI time diffTime m
-> VersionDataCodec vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      diffTime)
handshakeClientPeer' TimeAPI {m time
getTime :: forall time diffTime (m :: * -> *).
TimeAPI time diffTime m -> m time
getTime :: m time
getTime, time -> time -> diffTime
timeDiff :: forall time diffTime (m :: * -> *).
TimeAPI time diffTime m -> time -> time -> diffTime
timeDiff :: time -> time -> diffTime
timeDiff}
                     codec :: VersionDataCodec vNumber vData
codec@VersionDataCodec {vNumber -> vData -> Term
encodeData :: vNumber -> vData -> Term
encodeData :: forall v a. VersionDataCodec v a -> v -> a -> Term
encodeData, vNumber -> Term -> Either Text vData
decodeData :: vNumber -> Term -> Either Text vData
decodeData :: forall v a. VersionDataCodec v a -> v -> Term -> Either Text a
decodeData}
                     vData -> vData -> Accept vData
acceptVersion Versions vNumber vData r
versions =
  m (Client
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      diffTime))
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      diffTime)
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
m (Client ps pl st m a) -> Client ps pl st m a
Effect (m (Client
      (Handshake vNumber Term)
      'NonPipelined
      'StPropose
      m
      (Either
         (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
       diffTime))
 -> Client
      (Handshake vNumber Term)
      'NonPipelined
      'StPropose
      m
      (Either
         (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
       diffTime))
-> m (Client
        (Handshake vNumber Term)
        'NonPipelined
        'StPropose
        m
        (Either
           (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
         diffTime))
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      diffTime)
forall a b. (a -> b) -> a -> b
$ do
    start <- m time
getTime
    return $
      -- send known versions
      Yield (MsgProposeVersions $ encodeVersions encodeData versions) $

        Await $ \Message (Handshake vNumber Term) 'StConfirm st'
msg -> case Message (Handshake vNumber Term) 'StConfirm st'
msg of
          MsgReplyVersions Map vNumber1 vParams1
vMap -> m (Client
     (Handshake vNumber Term)
     'NonPipelined
     st'
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      diffTime))
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     st'
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      diffTime)
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
m (Client ps pl st m a) -> Client ps pl st m a
Effect (m (Client
      (Handshake vNumber Term)
      'NonPipelined
      st'
      m
      (Either
         (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
       diffTime))
 -> Client
      (Handshake vNumber Term)
      'NonPipelined
      st'
      m
      (Either
         (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
       diffTime))
-> m (Client
        (Handshake vNumber Term)
        'NonPipelined
        st'
        m
        (Either
           (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
         diffTime))
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     st'
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      diffTime)
forall a b. (a -> b) -> a -> b
$ do
            end <- m time
getTime
            -- simultaneous open; 'accept' will choose version (the greatest common
            -- version), and check if we can accept received version data.
            return $ Done $ case acceptOrRefuse codec acceptVersion versions vMap of
              Right (r
r, vNumber
vNumber, vData
vData) -> ( HandshakeResult r vNumber vData
-> Either
     (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData)
forall a b. b -> Either a b
Right (HandshakeResult r vNumber vData
 -> Either
      (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData))
-> HandshakeResult r vNumber vData
-> Either
     (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData)
forall a b. (a -> b) -> a -> b
$ r -> vNumber -> vData -> HandshakeResult r vNumber vData
forall r vNumber vData.
r -> vNumber -> vData -> HandshakeResult r vNumber vData
HandshakeNegotiationResult r
r vNumber
vNumber vData
vData
                                           , time
end time -> time -> diffTime
`timeDiff` time
start
                                           )
              Left RefuseReason vNumber
vReason              -> ( HandshakeProtocolError vNumber
-> Either
     (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData)
forall a b. a -> Either a b
Left (RefuseReason vNumber -> HandshakeProtocolError vNumber
forall vNumber.
RefuseReason vNumber -> HandshakeProtocolError vNumber
HandshakeError RefuseReason vNumber
vReason)
                                           , time
end time -> time -> diffTime
`timeDiff` time
start
                                           )

          MsgQueryReply Map vNumber1 vParams1
vMap -> m (Client
     (Handshake vNumber Term)
     'NonPipelined
     st'
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      diffTime))
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     st'
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      diffTime)
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
m (Client ps pl st m a) -> Client ps pl st m a
Effect (m (Client
      (Handshake vNumber Term)
      'NonPipelined
      st'
      m
      (Either
         (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
       diffTime))
 -> Client
      (Handshake vNumber Term)
      'NonPipelined
      st'
      m
      (Either
         (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
       diffTime))
-> m (Client
        (Handshake vNumber Term)
        'NonPipelined
        st'
        m
        (Either
           (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
         diffTime))
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     st'
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      diffTime)
forall a b. (a -> b) -> a -> b
$ do
            end <- m time
getTime
            return $ Done ( Right $ decodeQueryResult decodeData vMap
                          , end `timeDiff` start
                          )

          -- the server refused common highest version
          MsgRefuse RefuseReason vNumber1
vReason -> m (Client
     (Handshake vNumber Term)
     'NonPipelined
     st'
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      diffTime))
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     st'
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      diffTime)
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
m (Client ps pl st m a) -> Client ps pl st m a
Effect (m (Client
      (Handshake vNumber Term)
      'NonPipelined
      st'
      m
      (Either
         (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
       diffTime))
 -> Client
      (Handshake vNumber Term)
      'NonPipelined
      st'
      m
      (Either
         (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
       diffTime))
-> m (Client
        (Handshake vNumber Term)
        'NonPipelined
        st'
        m
        (Either
           (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
         diffTime))
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     st'
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      diffTime)
forall a b. (a -> b) -> a -> b
$ do
            end <- m time
getTime
            return $ Done ( Left $ HandshakeError vReason
                          , end `timeDiff` start
                          )

          -- the server accepted a version, sent back the version number and its
          -- version data blob
          MsgAcceptVersion vNumber1
vNumber vParams1
vParams -> m (Client
     (Handshake vNumber Term)
     'NonPipelined
     st'
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      diffTime))
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     st'
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      diffTime)
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
m (Client ps pl st m a) -> Client ps pl st m a
Effect (m (Client
      (Handshake vNumber Term)
      'NonPipelined
      st'
      m
      (Either
         (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
       diffTime))
 -> Client
      (Handshake vNumber Term)
      'NonPipelined
      st'
      m
      (Either
         (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
       diffTime))
-> m (Client
        (Handshake vNumber Term)
        'NonPipelined
        st'
        m
        (Either
           (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
         diffTime))
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     st'
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      diffTime)
forall a b. (a -> b) -> a -> b
$ do
            end <- m time
getTime
            return $ case vNumber `Map.lookup` getVersions versions of
              Maybe (Version vData r)
Nothing -> (Either
   (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
 diffTime)
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     st'
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      diffTime)
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
(StateTokenI st, StateAgency st ~ 'NobodyAgency,
 Outstanding pl ~ 'Z) =>
a -> Client ps pl st m a
Done ( HandshakeProtocolError vNumber
-> Either
     (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData)
forall a b. a -> Either a b
Left (HandshakeProtocolError vNumber
 -> Either
      (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData))
-> HandshakeProtocolError vNumber
-> Either
     (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData)
forall a b. (a -> b) -> a -> b
$ vNumber -> HandshakeProtocolError vNumber
forall vNumber. vNumber -> HandshakeProtocolError vNumber
NotRecognisedVersion vNumber
vNumber1
vNumber
                              , time
end time -> time -> diffTime
`timeDiff` time
start
                              )
              Just (Version vData -> r
app vData
vData) ->
                case vNumber -> Term -> Either Text vData
decodeData vNumber
vNumber1
vNumber vParams1
Term
vParams of

                  Left Text
err ->
                    (Either
   (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
 diffTime)
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     st'
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      diffTime)
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
(StateTokenI st, StateAgency st ~ 'NobodyAgency,
 Outstanding pl ~ 'Z) =>
a -> Client ps pl st m a
Done ( HandshakeProtocolError vNumber
-> Either
     (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData)
forall a b. a -> Either a b
Left (RefuseReason vNumber -> HandshakeProtocolError vNumber
forall vNumber.
RefuseReason vNumber -> HandshakeProtocolError vNumber
HandshakeError (RefuseReason vNumber -> HandshakeProtocolError vNumber)
-> RefuseReason vNumber -> HandshakeProtocolError vNumber
forall a b. (a -> b) -> a -> b
$ vNumber -> Text -> RefuseReason vNumber
forall vNumber. vNumber -> Text -> RefuseReason vNumber
HandshakeDecodeError vNumber
vNumber1
vNumber Text
err)
                         , time
end time -> time -> diffTime
`timeDiff` time
start
                         )

                  Right vData
vData' ->
                    case vData -> vData -> Accept vData
acceptVersion vData
vData vData
vData' of
                      Accept vData
agreedData ->
                        (Either
   (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
 diffTime)
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     st'
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      diffTime)
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
(StateTokenI st, StateAgency st ~ 'NobodyAgency,
 Outstanding pl ~ 'Z) =>
a -> Client ps pl st m a
Done ( HandshakeResult r vNumber vData
-> Either
     (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData)
forall a b. b -> Either a b
Right (HandshakeResult r vNumber vData
 -> Either
      (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData))
-> HandshakeResult r vNumber vData
-> Either
     (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData)
forall a b. (a -> b) -> a -> b
$ r -> vNumber -> vData -> HandshakeResult r vNumber vData
forall r vNumber vData.
r -> vNumber -> vData -> HandshakeResult r vNumber vData
HandshakeNegotiationResult (vData -> r
app vData
agreedData)
                                                                  vNumber
vNumber1
vNumber
                                                                  vData
agreedData
                              , time
end time -> time -> diffTime
`timeDiff` time
start
                              )
                      Refuse Text
err ->
                        (Either
   (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
 diffTime)
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     st'
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData),
      diffTime)
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
(StateTokenI st, StateAgency st ~ 'NobodyAgency,
 Outstanding pl ~ 'Z) =>
a -> Client ps pl st m a
Done ( HandshakeProtocolError vNumber
-> Either
     (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData)
forall a b. a -> Either a b
Left (vNumber -> Text -> HandshakeProtocolError vNumber
forall vNumber. vNumber -> Text -> HandshakeProtocolError vNumber
InvalidServerSelection vNumber
vNumber1
vNumber Text
err)
                             , time
end time -> time -> diffTime
`timeDiff` time
start
                             )


decodeQueryResult :: (vNumber -> bytes -> Either Text vData)
                  -> Map vNumber bytes
                  -> HandshakeResult r vNumber vData
decodeQueryResult :: forall vNumber bytes vData r.
(vNumber -> bytes -> Either Text vData)
-> Map vNumber bytes -> HandshakeResult r vNumber vData
decodeQueryResult vNumber -> bytes -> Either Text vData
decodeData Map vNumber bytes
vMap = Map vNumber (Either Text vData) -> HandshakeResult r vNumber vData
forall r vNumber vData.
Map vNumber (Either Text vData) -> HandshakeResult r vNumber vData
HandshakeQueryResult (Map vNumber (Either Text vData)
 -> HandshakeResult r vNumber vData)
-> Map vNumber (Either Text vData)
-> HandshakeResult r vNumber vData
forall a b. (a -> b) -> a -> b
$ (vNumber -> bytes -> Either Text vData)
-> Map vNumber bytes -> Map vNumber (Either Text vData)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey vNumber -> bytes -> Either Text vData
decodeData Map vNumber bytes
vMap

encodeVersions
  :: forall vNumber r vParams vData.
     (vNumber -> vData -> vParams)
  -> Versions vNumber vData r
  -> Map vNumber vParams
encodeVersions :: forall vNumber r vParams vData.
(vNumber -> vData -> vParams)
-> Versions vNumber vData r -> Map vNumber vParams
encodeVersions vNumber -> vData -> vParams
encoder (Versions Map vNumber (Version vData r)
vs) = vNumber -> Version vData r -> vParams
go (vNumber -> Version vData r -> vParams)
-> Map vNumber (Version vData r) -> Map vNumber vParams
forall k a b. (k -> a -> b) -> Map k a -> Map k b
`Map.mapWithKey` Map vNumber (Version vData r)
vs
    where
      go :: vNumber -> Version vData r -> vParams
      go :: vNumber -> Version vData r -> vParams
go vNumber
vNumber Version {vData
versionData :: vData
versionData :: forall vData r. Version vData r -> vData
versionData} = vNumber -> vData -> vParams
encoder vNumber
vNumber vData
versionData


acceptOrRefuse
  :: forall vNumber vData r.
     Ord vNumber
  => VersionDataCodec vNumber vData
  -> (vData -> vData -> Accept vData)
  -> Versions vNumber vData r
  -> Map vNumber CBOR.Term
  -- ^ proposed versions received either with `MsgProposeVersions` or
  -- `MsgReplyVersions`
  -> Either (RefuseReason vNumber) (r, vNumber, vData)
acceptOrRefuse :: forall vNumber vData r.
Ord vNumber =>
VersionDataCodec vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Map vNumber Term
-> Either (RefuseReason vNumber) (r, vNumber, vData)
acceptOrRefuse VersionDataCodec {vNumber -> Term -> Either Text vData
decodeData :: forall v a. VersionDataCodec v a -> v -> Term -> Either Text a
decodeData :: vNumber -> Term -> Either Text vData
decodeData}
               vData -> vData -> Accept vData
acceptVersion Versions vNumber vData r
versions Map vNumber Term
versionMap =
    case Map vNumber Term
-> Map vNumber (Version vData r)
-> Maybe (vNumber, (Term, Version vData r))
forall k a b. Ord k => Map k a -> Map k b -> Maybe (k, (a, b))
lookupGreatestCommonKey Map vNumber Term
versionMap (Versions vNumber vData r -> Map vNumber (Version vData r)
forall vNum vData r.
Versions vNum vData r -> Map vNum (Version vData r)
getVersions Versions vNumber vData r
versions) of
      Maybe (vNumber, (Term, Version vData r))
Nothing ->
        RefuseReason vNumber
-> Either (RefuseReason vNumber) (r, vNumber, vData)
forall a b. a -> Either a b
Left (RefuseReason vNumber
 -> Either (RefuseReason vNumber) (r, vNumber, vData))
-> RefuseReason vNumber
-> Either (RefuseReason vNumber) (r, vNumber, vData)
forall a b. (a -> b) -> a -> b
$ [vNumber] -> [Int] -> RefuseReason vNumber
forall vNumber. [vNumber] -> [Int] -> RefuseReason vNumber
VersionMismatch (Map vNumber (Version vData r) -> [vNumber]
forall k a. Map k a -> [k]
Map.keys (Map vNumber (Version vData r) -> [vNumber])
-> Map vNumber (Version vData r) -> [vNumber]
forall a b. (a -> b) -> a -> b
$ Versions vNumber vData r -> Map vNumber (Version vData r)
forall vNum vData r.
Versions vNum vData r -> Map vNum (Version vData r)
getVersions Versions vNumber vData r
versions) []

      Just (vNumber
vNumber, (Term
vParams, Version vData -> r
app vData
vData)) ->
        case vNumber -> Term -> Either Text vData
decodeData vNumber
vNumber Term
vParams of
          Left Text
err ->
            RefuseReason vNumber
-> Either (RefuseReason vNumber) (r, vNumber, vData)
forall a b. a -> Either a b
Left (vNumber -> Text -> RefuseReason vNumber
forall vNumber. vNumber -> Text -> RefuseReason vNumber
HandshakeDecodeError vNumber
vNumber Text
err)

          Right vData
vData' ->
            case vData -> vData -> Accept vData
acceptVersion vData
vData vData
vData' of
              Accept vData
agreedData ->
                (r, vNumber, vData)
-> Either (RefuseReason vNumber) (r, vNumber, vData)
forall a b. b -> Either a b
Right (vData -> r
app vData
agreedData, vNumber
vNumber, vData
agreedData)

              Refuse Text
err ->
                RefuseReason vNumber
-> Either (RefuseReason vNumber) (r, vNumber, vData)
forall a b. a -> Either a b
Left (vNumber -> Text -> RefuseReason vNumber
forall vNumber. vNumber -> Text -> RefuseReason vNumber
Refused vNumber
vNumber Text
err)


lookupGreatestCommonKey :: Ord k => Map k a -> Map k b -> Maybe (k, (a, b))
lookupGreatestCommonKey :: forall k a b. Ord k => Map k a -> Map k b -> Maybe (k, (a, b))
lookupGreatestCommonKey Map k a
l Map k b
r = Map k (a, b) -> Maybe (k, (a, b))
forall k a. Map k a -> Maybe (k, a)
Map.lookupMax (Map k (a, b) -> Maybe (k, (a, b)))
-> Map k (a, b) -> Maybe (k, (a, b))
forall a b. (a -> b) -> a -> b
$ (a -> b -> (a, b)) -> Map k a -> Map k b -> Map k (a, b)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (,) Map k a
l Map k b
r