{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | API for running 'Handshake' protocol.
--
module Ouroboros.Network.Protocol.Handshake
  ( runHandshakeClient
  , runHandshakeClientWithRTT
  , runHandshakeServer
  , HandshakeArguments (..)
  , Versions (..)
  , HandshakeException (..)
  , HandshakeProtocolError (..)
  , HandshakeResult (..)
  , RefuseReason (..)
  , Accept (..)
  , handshake_QUERY_SHUTDOWN_DELAY
    -- * Re-exports
  , module Ouroboros.Network.Protocol.Handshake.Type
  , module Ouroboros.Network.Protocol.Handshake.Codec
  , module Ouroboros.Network.Protocol.Handshake.Version
  , Acceptable (..)
  , Queryable (..)
  ) where

import Control.DeepSeq (NFData (..))
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadSTM
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTimer.SI
import Control.Tracer (Tracer, contramap)

import Codec.CBOR.Read qualified as CBOR
import Codec.CBOR.Term qualified as CBOR
import Data.ByteString.Lazy qualified as BL
import Data.Typeable (Typeable)
import GHC.Generics

import Network.Mux.Trace qualified as Mx
import Network.Mux.Types qualified as Mx
import Network.TypedProtocol.Codec

import Ouroboros.Network.Driver.Limits

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


-- | The handshake protocol number.
--
handshakeProtocolNum :: Mx.MiniProtocolNum
handshakeProtocolNum :: MiniProtocolNum
handshakeProtocolNum = Word16 -> MiniProtocolNum
Mx.MiniProtocolNum Word16
0

-- | Wrapper around initiator and responder errors experienced by tryHandshake.
--
-- TODO: should we have `Exception` instance?
-- It would be handly in `prop_socket_send_recgtv`.
--
data HandshakeException vNumber =
    HandshakeProtocolLimit ProtocolLimitFailure
  | HandshakeProtocolError (HandshakeProtocolError vNumber)
  deriving (Int -> HandshakeException vNumber -> ShowS
[HandshakeException vNumber] -> ShowS
HandshakeException vNumber -> String
(Int -> HandshakeException vNumber -> ShowS)
-> (HandshakeException vNumber -> String)
-> ([HandshakeException vNumber] -> ShowS)
-> Show (HandshakeException vNumber)
forall vNumber.
Show vNumber =>
Int -> HandshakeException vNumber -> ShowS
forall vNumber.
Show vNumber =>
[HandshakeException vNumber] -> ShowS
forall vNumber.
Show vNumber =>
HandshakeException vNumber -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall vNumber.
Show vNumber =>
Int -> HandshakeException vNumber -> ShowS
showsPrec :: Int -> HandshakeException vNumber -> ShowS
$cshow :: forall vNumber.
Show vNumber =>
HandshakeException vNumber -> String
show :: HandshakeException vNumber -> String
$cshowList :: forall vNumber.
Show vNumber =>
[HandshakeException vNumber] -> ShowS
showList :: [HandshakeException vNumber] -> ShowS
Show, (forall x.
 HandshakeException vNumber -> Rep (HandshakeException vNumber) x)
-> (forall x.
    Rep (HandshakeException vNumber) x -> HandshakeException vNumber)
-> Generic (HandshakeException vNumber)
forall x.
Rep (HandshakeException vNumber) x -> HandshakeException vNumber
forall x.
HandshakeException vNumber -> Rep (HandshakeException vNumber) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall vNumber x.
Rep (HandshakeException vNumber) x -> HandshakeException vNumber
forall vNumber x.
HandshakeException vNumber -> Rep (HandshakeException vNumber) x
$cfrom :: forall vNumber x.
HandshakeException vNumber -> Rep (HandshakeException vNumber) x
from :: forall x.
HandshakeException vNumber -> Rep (HandshakeException vNumber) x
$cto :: forall vNumber x.
Rep (HandshakeException vNumber) x -> HandshakeException vNumber
to :: forall x.
Rep (HandshakeException vNumber) x -> HandshakeException vNumber
Generic, HandshakeException vNumber -> ()
(HandshakeException vNumber -> ())
-> NFData (HandshakeException vNumber)
forall vNumber. NFData vNumber => HandshakeException vNumber -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall vNumber. NFData vNumber => HandshakeException vNumber -> ()
rnf :: HandshakeException vNumber -> ()
NFData)

instance ( Typeable versionNumber
         , Show versionNumber
         )
      => Exception (HandshakeException versionNumber) where
  displayException :: HandshakeException versionNumber -> String
displayException (HandshakeProtocolLimit ProtocolLimitFailure
failure) = String
"handshake protocol limits: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ProtocolLimitFailure -> String
forall a. Show a => a -> String
show ProtocolLimitFailure
failure
  displayException (HandshakeProtocolError HandshakeProtocolError versionNumber
err)     = String
"handshake protocol error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ HandshakeProtocolError versionNumber -> String
forall a. Show a => a -> String
show HandshakeProtocolError versionNumber
err


-- | Try to complete either initiator or responder side of the Handshake protocol
-- within `handshakeTimeout` seconds.
--
tryHandshake :: forall m vNumber r.
                ( MonadAsync m
                , MonadMask m
                )
             => m (Either (HandshakeProtocolError vNumber) r)
             -> m (Either (HandshakeException vNumber)     r)
tryHandshake :: forall (m :: * -> *) vNumber r.
(MonadAsync m, MonadMask m) =>
m (Either (HandshakeProtocolError vNumber) r)
-> m (Either (HandshakeException vNumber) r)
tryHandshake m (Either (HandshakeProtocolError vNumber) r)
doHandshake = do
    mapp <- m (Either (HandshakeProtocolError vNumber) r)
-> m (Either
        ProtocolLimitFailure (Either (HandshakeProtocolError vNumber) r))
forall e a. Exception e => m a -> m (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try m (Either (HandshakeProtocolError vNumber) r)
doHandshake
    case mapp of
      Left ProtocolLimitFailure
err ->
          Either (HandshakeException vNumber) r
-> m (Either (HandshakeException vNumber) r)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (HandshakeException vNumber) r
 -> m (Either (HandshakeException vNumber) r))
-> Either (HandshakeException vNumber) r
-> m (Either (HandshakeException vNumber) r)
forall a b. (a -> b) -> a -> b
$ HandshakeException vNumber -> Either (HandshakeException vNumber) r
forall a b. a -> Either a b
Left (HandshakeException vNumber
 -> Either (HandshakeException vNumber) r)
-> HandshakeException vNumber
-> Either (HandshakeException vNumber) r
forall a b. (a -> b) -> a -> b
$ ProtocolLimitFailure -> HandshakeException vNumber
forall vNumber. ProtocolLimitFailure -> HandshakeException vNumber
HandshakeProtocolLimit ProtocolLimitFailure
err
      Right (Left HandshakeProtocolError vNumber
err) ->
          Either (HandshakeException vNumber) r
-> m (Either (HandshakeException vNumber) r)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (HandshakeException vNumber) r
 -> m (Either (HandshakeException vNumber) r))
-> Either (HandshakeException vNumber) r
-> m (Either (HandshakeException vNumber) r)
forall a b. (a -> b) -> a -> b
$ HandshakeException vNumber -> Either (HandshakeException vNumber) r
forall a b. a -> Either a b
Left (HandshakeException vNumber
 -> Either (HandshakeException vNumber) r)
-> HandshakeException vNumber
-> Either (HandshakeException vNumber) r
forall a b. (a -> b) -> a -> b
$ HandshakeProtocolError vNumber -> HandshakeException vNumber
forall vNumber.
HandshakeProtocolError vNumber -> HandshakeException vNumber
HandshakeProtocolError HandshakeProtocolError vNumber
err
      Right (Right r
r) -> Either (HandshakeException vNumber) r
-> m (Either (HandshakeException vNumber) r)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (HandshakeException vNumber) r
 -> m (Either (HandshakeException vNumber) r))
-> Either (HandshakeException vNumber) r
-> m (Either (HandshakeException vNumber) r)
forall a b. (a -> b) -> a -> b
$ r -> Either (HandshakeException vNumber) r
forall a b. b -> Either a b
Right r
r

--
-- Record arguments
--

-- | Common arguments for both 'Handshake' client & server.
--
data HandshakeArguments connectionId vNumber vData m = HandshakeArguments {
      -- | 'Handshake' tracer
      --
      forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> Tracer
     m
     (WithBearer connectionId (TraceSendRecv (Handshake vNumber Term)))
haHandshakeTracer
        :: Tracer m (Mx.WithBearer connectionId
                                   (TraceSendRecv (Handshake vNumber CBOR.Term))),

      forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> Tracer m (WithBearer connectionId BearerTrace)
haBearerTracer
        :: Tracer m (Mx.WithBearer connectionId Mx.BearerTrace),

      -- | Codec for protocol messages.
      --
      forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
haHandshakeCodec
        ::  Codec (Handshake vNumber CBOR.Term) CBOR.DeserialiseFailure m BL.ByteString,

      -- | A codec for protocol parameters.
      --
      forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> VersionDataCodec vNumber vData
haVersionDataCodec
        ::  VersionDataCodec vNumber vData,

      -- | accept version, first argument is our version data the second
      -- argument is the remote version data.
      forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> vData -> vData -> Accept vData
haAcceptVersion :: vData -> vData -> Accept vData,

      -- | Whether version data requested a query of support version.
      --
      forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m -> vData -> Bool
haQueryVersion :: vData -> Bool,

      -- | 'Driver' timeouts for 'Handshake' protocol.
      --
      forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> ProtocolTimeLimits (Handshake vNumber Term)
haTimeLimits
        :: ProtocolTimeLimits (Handshake vNumber CBOR.Term)
    }


-- | Run client side of the 'Handshake' protocol.
--
runHandshakeClient
    :: forall versionNumber versionData application connId m.
       ( MonadAsync m
       , MonadEvaluate m
       , MonadFork m
       , MonadTimer m
       , MonadMask m
       , MonadThrow (STM m)
       , Ord versionNumber
       , NFData versionNumber
       , NFData versionData
       )
    => Mx.Bearer m
    -> connId
    -> HandshakeArguments connId versionNumber versionData m
    -> Versions versionNumber versionData application
    -> m (Either (HandshakeException versionNumber)
                 (HandshakeResult application versionNumber versionData))
runHandshakeClient :: forall versionNumber versionData application connId (m :: * -> *).
(MonadAsync m, MonadEvaluate m, MonadFork m, MonadTimer m,
 MonadMask m, MonadThrow (STM m), Ord versionNumber,
 NFData versionNumber, NFData versionData) =>
Bearer m
-> connId
-> HandshakeArguments connId versionNumber versionData m
-> Versions versionNumber versionData application
-> m (Either
        (HandshakeException versionNumber)
        (HandshakeResult application versionNumber versionData))
runHandshakeClient Bearer m
bearer connId
connectionId
                   HandshakeArguments {
                     Tracer
  m
  (WithBearer connId (TraceSendRecv (Handshake versionNumber Term)))
haHandshakeTracer :: forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> Tracer
     m
     (WithBearer connectionId (TraceSendRecv (Handshake vNumber Term)))
haHandshakeTracer :: Tracer
  m
  (WithBearer connId (TraceSendRecv (Handshake versionNumber Term)))
haHandshakeTracer,
                     Tracer m (WithBearer connId BearerTrace)
haBearerTracer :: forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> Tracer m (WithBearer connectionId BearerTrace)
haBearerTracer :: Tracer m (WithBearer connId BearerTrace)
haBearerTracer,
                     Codec
  (Handshake versionNumber Term) DeserialiseFailure m ByteString
haHandshakeCodec :: forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
haHandshakeCodec :: Codec
  (Handshake versionNumber Term) DeserialiseFailure m ByteString
haHandshakeCodec,
                     VersionDataCodec versionNumber versionData
haVersionDataCodec :: forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> VersionDataCodec vNumber vData
haVersionDataCodec :: VersionDataCodec versionNumber versionData
haVersionDataCodec,
                     versionData -> versionData -> Accept versionData
haAcceptVersion :: forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> vData -> vData -> Accept vData
haAcceptVersion :: versionData -> versionData -> Accept versionData
haAcceptVersion,
                     ProtocolTimeLimits (Handshake versionNumber Term)
haTimeLimits :: forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> ProtocolTimeLimits (Handshake vNumber Term)
haTimeLimits :: ProtocolTimeLimits (Handshake versionNumber Term)
haTimeLimits
                   }
                   Versions versionNumber versionData application
versions =
  m (Either
     (HandshakeProtocolError versionNumber)
     (HandshakeResult application versionNumber versionData))
-> m (Either
        (HandshakeException versionNumber)
        (HandshakeResult application versionNumber versionData))
forall (m :: * -> *) vNumber r.
(MonadAsync m, MonadMask m) =>
m (Either (HandshakeProtocolError vNumber) r)
-> m (Either (HandshakeException vNumber) r)
tryHandshake
    ((Either
   (HandshakeProtocolError versionNumber)
   (HandshakeResult application versionNumber versionData),
 Maybe ByteString)
-> Either
     (HandshakeProtocolError versionNumber)
     (HandshakeResult application versionNumber versionData)
forall a b. (a, b) -> a
fst ((Either
    (HandshakeProtocolError versionNumber)
    (HandshakeResult application versionNumber versionData),
  Maybe ByteString)
 -> Either
      (HandshakeProtocolError versionNumber)
      (HandshakeResult application versionNumber versionData))
-> m (Either
        (HandshakeProtocolError versionNumber)
        (HandshakeResult application versionNumber versionData),
      Maybe ByteString)
-> m (Either
        (HandshakeProtocolError versionNumber)
        (HandshakeResult application versionNumber versionData))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      Tracer m (TraceSendRecv (Handshake versionNumber Term))
-> Codec
     (Handshake versionNumber Term) DeserialiseFailure m ByteString
-> ProtocolSizeLimits (Handshake versionNumber Term) ByteString
-> ProtocolTimeLimits (Handshake versionNumber Term)
-> Channel m ByteString
-> Peer
     (Handshake versionNumber Term)
     'AsClient
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError versionNumber)
        (HandshakeResult application versionNumber versionData))
-> m (Either
        (HandshakeProtocolError versionNumber)
        (HandshakeResult application versionNumber versionData),
      Maybe ByteString)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadEvaluate m, MonadFork m, MonadMask m,
 MonadThrow (STM m), MonadTimer m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 NFData a, NFData failure, Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeerWithLimits
        (connId
-> TraceSendRecv (Handshake versionNumber Term)
-> WithBearer connId (TraceSendRecv (Handshake versionNumber Term))
forall peerid a. peerid -> a -> WithBearer peerid a
Mx.WithBearer connId
connectionId (TraceSendRecv (Handshake versionNumber Term)
 -> WithBearer
      connId (TraceSendRecv (Handshake versionNumber Term)))
-> Tracer
     m
     (WithBearer connId (TraceSendRecv (Handshake versionNumber Term)))
-> Tracer m (TraceSendRecv (Handshake versionNumber Term))
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap` Tracer
  m
  (WithBearer connId (TraceSendRecv (Handshake versionNumber Term)))
haHandshakeTracer)
        Codec
  (Handshake versionNumber Term) DeserialiseFailure m ByteString
haHandshakeCodec
        ProtocolSizeLimits (Handshake versionNumber Term) ByteString
forall {k} (vNumber :: k).
ProtocolSizeLimits (Handshake vNumber Term) ByteString
byteLimitsHandshake
        ProtocolTimeLimits (Handshake versionNumber Term)
haTimeLimits
        (Tracer m BearerTrace
-> Bearer m
-> MiniProtocolNum
-> MiniProtocolDir
-> Channel m ByteString
forall (m :: * -> *).
Functor m =>
Tracer m BearerTrace
-> Bearer m -> MiniProtocolNum -> MiniProtocolDir -> ByteChannel m
Mx.bearerAsChannel (connId -> BearerTrace -> WithBearer connId BearerTrace
forall peerid a. peerid -> a -> WithBearer peerid a
Mx.WithBearer connId
connectionId (BearerTrace -> WithBearer connId BearerTrace)
-> Tracer m (WithBearer connId BearerTrace) -> Tracer m BearerTrace
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap` Tracer m (WithBearer connId BearerTrace)
haBearerTracer)
                            Bearer m
bearer MiniProtocolNum
handshakeProtocolNum MiniProtocolDir
Mx.InitiatorDir)
        (VersionDataCodec versionNumber versionData
-> (versionData -> versionData -> Accept versionData)
-> Versions versionNumber versionData application
-> Peer
     (Handshake versionNumber Term)
     'AsClient
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError versionNumber)
        (HandshakeResult application versionNumber versionData))
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 versionNumber versionData
haVersionDataCodec versionData -> versionData -> Accept versionData
haAcceptVersion Versions versionNumber versionData application
versions))

-- | Run client side of the 'Handshake' protocol and compute RTT.
--
runHandshakeClientWithRTT
    :: forall versionNumber versionData application connId m.
       ( MonadAsync m
       , MonadEvaluate m
       , MonadFork m
       , MonadTimer m
       , MonadMask m
       , MonadThrow (STM m)
       , Ord versionNumber
       , NFData versionNumber
       , NFData versionData
       )
    => Mx.Bearer m
    -> connId
    -> HandshakeArguments connId versionNumber versionData m
    -> Versions versionNumber versionData application
    -> m (Either ProtocolLimitFailure
                 ( Either (HandshakeProtocolError versionNumber)
                          (HandshakeResult application versionNumber versionData)
                 , DiffTime
                 ))
runHandshakeClientWithRTT :: forall versionNumber versionData application connId (m :: * -> *).
(MonadAsync m, MonadEvaluate m, MonadFork m, MonadTimer m,
 MonadMask m, MonadThrow (STM m), Ord versionNumber,
 NFData versionNumber, NFData versionData) =>
Bearer m
-> connId
-> HandshakeArguments connId versionNumber versionData m
-> Versions versionNumber versionData application
-> m (Either
        ProtocolLimitFailure
        (Either
           (HandshakeProtocolError versionNumber)
           (HandshakeResult application versionNumber versionData),
         DiffTime))
runHandshakeClientWithRTT
  Bearer m
bearer
  connId
connectionId
  HandshakeArguments {
    Tracer
  m
  (WithBearer connId (TraceSendRecv (Handshake versionNumber Term)))
haHandshakeTracer :: forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> Tracer
     m
     (WithBearer connectionId (TraceSendRecv (Handshake vNumber Term)))
haHandshakeTracer :: Tracer
  m
  (WithBearer connId (TraceSendRecv (Handshake versionNumber Term)))
haHandshakeTracer,
    Tracer m (WithBearer connId BearerTrace)
haBearerTracer :: forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> Tracer m (WithBearer connectionId BearerTrace)
haBearerTracer :: Tracer m (WithBearer connId BearerTrace)
haBearerTracer,
    Codec
  (Handshake versionNumber Term) DeserialiseFailure m ByteString
haHandshakeCodec :: forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
haHandshakeCodec :: Codec
  (Handshake versionNumber Term) DeserialiseFailure m ByteString
haHandshakeCodec,
    VersionDataCodec versionNumber versionData
haVersionDataCodec :: forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> VersionDataCodec vNumber vData
haVersionDataCodec :: VersionDataCodec versionNumber versionData
haVersionDataCodec,
    versionData -> versionData -> Accept versionData
haAcceptVersion :: forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> vData -> vData -> Accept vData
haAcceptVersion :: versionData -> versionData -> Accept versionData
haAcceptVersion,
    ProtocolTimeLimits (Handshake versionNumber Term)
haTimeLimits :: forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> ProtocolTimeLimits (Handshake vNumber Term)
haTimeLimits :: ProtocolTimeLimits (Handshake versionNumber Term)
haTimeLimits
  }
  Versions versionNumber versionData application
versions
  =
  m (Either
     (HandshakeProtocolError versionNumber)
     (HandshakeResult application versionNumber versionData),
   DiffTime)
-> m (Either
        ProtocolLimitFailure
        (Either
           (HandshakeProtocolError versionNumber)
           (HandshakeResult application versionNumber versionData),
         DiffTime))
forall r.
m (Either (HandshakeProtocolError versionNumber) r, DiffTime)
-> m (Either
        ProtocolLimitFailure
        (Either (HandshakeProtocolError versionNumber) r, DiffTime))
tryHandshakeWithRTT
    (((Either
    (HandshakeProtocolError versionNumber)
    (HandshakeResult application versionNumber versionData),
  DiffTime),
 Maybe ByteString)
-> (Either
      (HandshakeProtocolError versionNumber)
      (HandshakeResult application versionNumber versionData),
    DiffTime)
forall a b. (a, b) -> a
fst (((Either
     (HandshakeProtocolError versionNumber)
     (HandshakeResult application versionNumber versionData),
   DiffTime),
  Maybe ByteString)
 -> (Either
       (HandshakeProtocolError versionNumber)
       (HandshakeResult application versionNumber versionData),
     DiffTime))
-> m ((Either
         (HandshakeProtocolError versionNumber)
         (HandshakeResult application versionNumber versionData),
       DiffTime),
      Maybe ByteString)
-> m (Either
        (HandshakeProtocolError versionNumber)
        (HandshakeResult application versionNumber versionData),
      DiffTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      Tracer m (TraceSendRecv (Handshake versionNumber Term))
-> Codec
     (Handshake versionNumber Term) DeserialiseFailure m ByteString
-> ProtocolSizeLimits (Handshake versionNumber Term) ByteString
-> ProtocolTimeLimits (Handshake versionNumber Term)
-> Channel m ByteString
-> Peer
     (Handshake versionNumber Term)
     'AsClient
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError versionNumber)
        (HandshakeResult application versionNumber versionData),
      DiffTime)
-> m ((Either
         (HandshakeProtocolError versionNumber)
         (HandshakeResult application versionNumber versionData),
       DiffTime),
      Maybe ByteString)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadEvaluate m, MonadFork m, MonadMask m,
 MonadThrow (STM m), MonadTimer m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 NFData a, NFData failure, Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeerWithLimits
        (connId
-> TraceSendRecv (Handshake versionNumber Term)
-> WithBearer connId (TraceSendRecv (Handshake versionNumber Term))
forall peerid a. peerid -> a -> WithBearer peerid a
Mx.WithBearer connId
connectionId (TraceSendRecv (Handshake versionNumber Term)
 -> WithBearer
      connId (TraceSendRecv (Handshake versionNumber Term)))
-> Tracer
     m
     (WithBearer connId (TraceSendRecv (Handshake versionNumber Term)))
-> Tracer m (TraceSendRecv (Handshake versionNumber Term))
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap` Tracer
  m
  (WithBearer connId (TraceSendRecv (Handshake versionNumber Term)))
haHandshakeTracer)
        Codec
  (Handshake versionNumber Term) DeserialiseFailure m ByteString
haHandshakeCodec
        ProtocolSizeLimits (Handshake versionNumber Term) ByteString
forall {k} (vNumber :: k).
ProtocolSizeLimits (Handshake vNumber Term) ByteString
byteLimitsHandshake
        ProtocolTimeLimits (Handshake versionNumber Term)
haTimeLimits
        (Tracer m BearerTrace
-> Bearer m
-> MiniProtocolNum
-> MiniProtocolDir
-> Channel m ByteString
forall (m :: * -> *).
Functor m =>
Tracer m BearerTrace
-> Bearer m -> MiniProtocolNum -> MiniProtocolDir -> ByteChannel m
Mx.bearerAsChannel (connId -> BearerTrace -> WithBearer connId BearerTrace
forall peerid a. peerid -> a -> WithBearer peerid a
Mx.WithBearer connId
connectionId (BearerTrace -> WithBearer connId BearerTrace)
-> Tracer m (WithBearer connId BearerTrace) -> Tracer m BearerTrace
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap` Tracer m (WithBearer connId BearerTrace)
haBearerTracer)
                            Bearer m
bearer MiniProtocolNum
handshakeProtocolNum MiniProtocolDir
Mx.InitiatorDir)
        (VersionDataCodec versionNumber versionData
-> (versionData -> versionData -> Accept versionData)
-> Versions versionNumber versionData application
-> Peer
     (Handshake versionNumber Term)
     'AsClient
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError versionNumber)
        (HandshakeResult application versionNumber versionData),
      DiffTime)
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 VersionDataCodec versionNumber versionData
haVersionDataCodec versionData -> versionData -> Accept versionData
haAcceptVersion Versions versionNumber versionData application
versions))
  where
    tryHandshakeWithRTT :: forall r.
                           m ( Either (HandshakeProtocolError versionNumber) r
                             , DiffTime
                             )
                        -> m (Either ProtocolLimitFailure ( Either (HandshakeProtocolError versionNumber) r
                                                          , DiffTime
                                                          ))
    tryHandshakeWithRTT :: forall r.
m (Either (HandshakeProtocolError versionNumber) r, DiffTime)
-> m (Either
        ProtocolLimitFailure
        (Either (HandshakeProtocolError versionNumber) r, DiffTime))
tryHandshakeWithRTT = m (Either (HandshakeProtocolError versionNumber) r, DiffTime)
-> m (Either
        ProtocolLimitFailure
        (Either (HandshakeProtocolError versionNumber) r, DiffTime))
forall e a. Exception e => m a -> m (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try


-- | Run server side of the 'Handshake' protocol.
--
runHandshakeServer
    :: forall versionNumber versionData application connId m.
       ( MonadAsync m
       , MonadEvaluate m
       , MonadFork m
       , MonadTimer m
       , MonadMask m
       , MonadThrow (STM m)
       , Ord versionNumber
       , NFData versionNumber
       , NFData versionData
       )
    => Mx.Bearer m
    -> connId
    -> HandshakeArguments connId versionNumber versionData m
    -> Versions versionNumber versionData application
    -> m (Either (HandshakeException versionNumber)
                 (HandshakeResult application versionNumber versionData))
runHandshakeServer :: forall versionNumber versionData application connId (m :: * -> *).
(MonadAsync m, MonadEvaluate m, MonadFork m, MonadTimer m,
 MonadMask m, MonadThrow (STM m), Ord versionNumber,
 NFData versionNumber, NFData versionData) =>
Bearer m
-> connId
-> HandshakeArguments connId versionNumber versionData m
-> Versions versionNumber versionData application
-> m (Either
        (HandshakeException versionNumber)
        (HandshakeResult application versionNumber versionData))
runHandshakeServer Bearer m
bearer
                   connId
connectionId
                   HandshakeArguments {
                     Tracer
  m
  (WithBearer connId (TraceSendRecv (Handshake versionNumber Term)))
haHandshakeTracer :: forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> Tracer
     m
     (WithBearer connectionId (TraceSendRecv (Handshake vNumber Term)))
haHandshakeTracer :: Tracer
  m
  (WithBearer connId (TraceSendRecv (Handshake versionNumber Term)))
haHandshakeTracer,
                     Tracer m (WithBearer connId BearerTrace)
haBearerTracer :: forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> Tracer m (WithBearer connectionId BearerTrace)
haBearerTracer :: Tracer m (WithBearer connId BearerTrace)
haBearerTracer,
                     Codec
  (Handshake versionNumber Term) DeserialiseFailure m ByteString
haHandshakeCodec :: forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
haHandshakeCodec :: Codec
  (Handshake versionNumber Term) DeserialiseFailure m ByteString
haHandshakeCodec,
                     VersionDataCodec versionNumber versionData
haVersionDataCodec :: forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> VersionDataCodec vNumber vData
haVersionDataCodec :: VersionDataCodec versionNumber versionData
haVersionDataCodec,
                     versionData -> versionData -> Accept versionData
haAcceptVersion :: forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> vData -> vData -> Accept vData
haAcceptVersion :: versionData -> versionData -> Accept versionData
haAcceptVersion,
                     versionData -> Bool
haQueryVersion :: forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m -> vData -> Bool
haQueryVersion :: versionData -> Bool
haQueryVersion,
                     ProtocolTimeLimits (Handshake versionNumber Term)
haTimeLimits :: forall connectionId vNumber vData (m :: * -> *).
HandshakeArguments connectionId vNumber vData m
-> ProtocolTimeLimits (Handshake vNumber Term)
haTimeLimits :: ProtocolTimeLimits (Handshake versionNumber Term)
haTimeLimits
                   }
                   Versions versionNumber versionData application
versions  =
    m (Either
     (HandshakeProtocolError versionNumber)
     (HandshakeResult application versionNumber versionData))
-> m (Either
        (HandshakeException versionNumber)
        (HandshakeResult application versionNumber versionData))
forall (m :: * -> *) vNumber r.
(MonadAsync m, MonadMask m) =>
m (Either (HandshakeProtocolError vNumber) r)
-> m (Either (HandshakeException vNumber) r)
tryHandshake
      ((Either
   (HandshakeProtocolError versionNumber)
   (HandshakeResult application versionNumber versionData),
 Maybe ByteString)
-> Either
     (HandshakeProtocolError versionNumber)
     (HandshakeResult application versionNumber versionData)
forall a b. (a, b) -> a
fst ((Either
    (HandshakeProtocolError versionNumber)
    (HandshakeResult application versionNumber versionData),
  Maybe ByteString)
 -> Either
      (HandshakeProtocolError versionNumber)
      (HandshakeResult application versionNumber versionData))
-> m (Either
        (HandshakeProtocolError versionNumber)
        (HandshakeResult application versionNumber versionData),
      Maybe ByteString)
-> m (Either
        (HandshakeProtocolError versionNumber)
        (HandshakeResult application versionNumber versionData))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Tracer m (TraceSendRecv (Handshake versionNumber Term))
-> Codec
     (Handshake versionNumber Term) DeserialiseFailure m ByteString
-> ProtocolSizeLimits (Handshake versionNumber Term) ByteString
-> ProtocolTimeLimits (Handshake versionNumber Term)
-> Channel m ByteString
-> Peer
     (Handshake versionNumber Term)
     'AsServer
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError versionNumber)
        (HandshakeResult application versionNumber versionData))
-> m (Either
        (HandshakeProtocolError versionNumber)
        (HandshakeResult application versionNumber versionData),
      Maybe ByteString)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadEvaluate m, MonadFork m, MonadMask m,
 MonadThrow (STM m), MonadTimer m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 NFData a, NFData failure, Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeerWithLimits
          (connId
-> TraceSendRecv (Handshake versionNumber Term)
-> WithBearer connId (TraceSendRecv (Handshake versionNumber Term))
forall peerid a. peerid -> a -> WithBearer peerid a
Mx.WithBearer connId
connectionId (TraceSendRecv (Handshake versionNumber Term)
 -> WithBearer
      connId (TraceSendRecv (Handshake versionNumber Term)))
-> Tracer
     m
     (WithBearer connId (TraceSendRecv (Handshake versionNumber Term)))
-> Tracer m (TraceSendRecv (Handshake versionNumber Term))
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap` Tracer
  m
  (WithBearer connId (TraceSendRecv (Handshake versionNumber Term)))
haHandshakeTracer)
          Codec
  (Handshake versionNumber Term) DeserialiseFailure m ByteString
haHandshakeCodec
          ProtocolSizeLimits (Handshake versionNumber Term) ByteString
forall {k} (vNumber :: k).
ProtocolSizeLimits (Handshake vNumber Term) ByteString
byteLimitsHandshake
          ProtocolTimeLimits (Handshake versionNumber Term)
haTimeLimits
          (Tracer m BearerTrace
-> Bearer m
-> MiniProtocolNum
-> MiniProtocolDir
-> Channel m ByteString
forall (m :: * -> *).
Functor m =>
Tracer m BearerTrace
-> Bearer m -> MiniProtocolNum -> MiniProtocolDir -> ByteChannel m
Mx.bearerAsChannel (connId -> BearerTrace -> WithBearer connId BearerTrace
forall peerid a. peerid -> a -> WithBearer peerid a
Mx.WithBearer connId
connectionId (BearerTrace -> WithBearer connId BearerTrace)
-> Tracer m (WithBearer connId BearerTrace) -> Tracer m BearerTrace
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap` Tracer m (WithBearer connId BearerTrace)
haBearerTracer)
                              Bearer m
bearer MiniProtocolNum
handshakeProtocolNum MiniProtocolDir
Mx.ResponderDir)
          (VersionDataCodec versionNumber versionData
-> (versionData -> versionData -> Accept versionData)
-> (versionData -> Bool)
-> Versions versionNumber versionData application
-> Peer
     (Handshake versionNumber Term)
     'AsServer
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError versionNumber)
        (HandshakeResult application versionNumber versionData))
forall vNumber vData r (m :: * -> *).
Ord vNumber =>
VersionDataCodec vNumber vData
-> (vData -> vData -> Accept vData)
-> (vData -> Bool)
-> Versions vNumber vData r
-> Server
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData))
handshakeServerPeer VersionDataCodec versionNumber versionData
haVersionDataCodec versionData -> versionData -> Accept versionData
haAcceptVersion versionData -> Bool
haQueryVersion Versions versionNumber versionData application
versions))

-- | A 20s delay after query result was send back, before we close the
-- connection.  After that delay we close the connection.
--
handshake_QUERY_SHUTDOWN_DELAY :: DiffTime
handshake_QUERY_SHUTDOWN_DELAY :: DiffTime
handshake_QUERY_SHUTDOWN_DELAY = DiffTime
20