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

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

import           Data.Map (Map)
import qualified Data.Map as Map

import qualified Codec.CBOR.Term as CBOR

import           Network.TypedProtocol.Core

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.
--
-- TODO: GADT encoding of the client (@Handshake.Client@ module).
--
handshakeClientPeer
  :: ( Ord vNumber
     )
  => VersionDataCodec CBOR.Term vNumber vData
  -> (vData -> vData -> Accept vData)
  -> Versions vNumber vData r
  -> Peer (Handshake vNumber CBOR.Term)
          AsClient StPropose m
          (Either
            (HandshakeProtocolError vNumber)
            (r, vNumber, vData))
handshakeClientPeer :: VersionDataCodec Term vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Peer
     (Handshake vNumber Term)
     'AsClient
     'StPropose
     m
     (Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
handshakeClientPeer codec :: VersionDataCodec Term vNumber vData
codec@VersionDataCodec {vNumber -> vData -> Term
encodeData :: forall bytes vNumber vData.
VersionDataCodec bytes vNumber vData -> vNumber -> vData -> bytes
encodeData :: vNumber -> vData -> Term
encodeData, vNumber -> Term -> Either Text vData
decodeData :: forall bytes vNumber vData.
VersionDataCodec bytes vNumber vData
-> vNumber -> bytes -> Either Text vData
decodeData :: vNumber -> Term -> Either Text vData
decodeData}
                    vData -> vData -> Accept vData
acceptVersion Versions vNumber vData r
versions =
  -- send known versions
  WeHaveAgency 'AsClient 'StPropose
-> Message (Handshake vNumber Term) 'StPropose 'StConfirm
-> Peer
     (Handshake vNumber Term)
     'AsClient
     'StConfirm
     m
     (Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
-> Peer
     (Handshake vNumber Term)
     'AsClient
     'StPropose
     m
     (Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
forall (pr :: PeerRole) ps (st :: ps) (st' :: ps) (m :: * -> *) a.
WeHaveAgency pr st
-> Message ps st st' -> Peer ps pr st' m a -> Peer ps pr st m a
Yield (ClientHasAgency 'StPropose -> WeHaveAgency 'AsClient 'StPropose
forall ps (st :: ps).
ClientHasAgency st -> PeerHasAgency 'AsClient st
ClientAgency ClientHasAgency 'StPropose
forall k k (vNumber :: k) (vParams :: k).
ClientHasAgency 'StPropose
TokPropose) (Map vNumber Term
-> Message (Handshake vNumber Term) 'StPropose 'StConfirm
forall vNumber vParams.
Map vNumber vParams
-> Message (Handshake vNumber vParams) 'StPropose 'StConfirm
MsgProposeVersions (Map vNumber Term
 -> Message (Handshake vNumber Term) 'StPropose 'StConfirm)
-> Map vNumber Term
-> Message (Handshake vNumber Term) 'StPropose 'StConfirm
forall a b. (a -> b) -> a -> b
$ (vNumber -> vData -> Term)
-> Versions vNumber vData r -> Map vNumber Term
forall vNumber r vParams vData.
(vNumber -> vData -> vParams)
-> Versions vNumber vData r -> Map vNumber vParams
encodeVersions vNumber -> vData -> Term
encodeData Versions vNumber vData r
versions) (Peer
   (Handshake vNumber Term)
   'AsClient
   'StConfirm
   m
   (Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
 -> Peer
      (Handshake vNumber Term)
      'AsClient
      'StPropose
      m
      (Either (HandshakeProtocolError vNumber) (r, vNumber, vData)))
-> Peer
     (Handshake vNumber Term)
     'AsClient
     'StConfirm
     m
     (Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
-> Peer
     (Handshake vNumber Term)
     'AsClient
     'StPropose
     m
     (Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
forall a b. (a -> b) -> a -> b
$

    TheyHaveAgency 'AsClient 'StConfirm
-> (forall (st' :: Handshake vNumber Term).
    Message (Handshake vNumber Term) 'StConfirm st'
    -> Peer
         (Handshake vNumber Term)
         'AsClient
         st'
         m
         (Either (HandshakeProtocolError vNumber) (r, vNumber, vData)))
-> Peer
     (Handshake vNumber Term)
     'AsClient
     'StConfirm
     m
     (Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
forall (pr :: PeerRole) ps (st :: ps) (m :: * -> *) a.
TheyHaveAgency pr st
-> (forall (st' :: ps). Message ps st st' -> Peer ps pr st' m a)
-> Peer ps pr st m a
Await (ServerHasAgency 'StConfirm -> PeerHasAgency 'AsServer 'StConfirm
forall ps (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
ServerAgency ServerHasAgency 'StConfirm
forall k k (vNumber :: k) (vParams :: k).
ServerHasAgency 'StConfirm
TokConfirm) ((forall (st' :: Handshake vNumber Term).
  Message (Handshake vNumber Term) 'StConfirm st'
  -> Peer
       (Handshake vNumber Term)
       'AsClient
       st'
       m
       (Either (HandshakeProtocolError vNumber) (r, vNumber, vData)))
 -> Peer
      (Handshake vNumber Term)
      'AsClient
      'StConfirm
      m
      (Either (HandshakeProtocolError vNumber) (r, vNumber, vData)))
-> (forall (st' :: Handshake vNumber Term).
    Message (Handshake vNumber Term) 'StConfirm st'
    -> Peer
         (Handshake vNumber Term)
         'AsClient
         st'
         m
         (Either (HandshakeProtocolError vNumber) (r, vNumber, vData)))
-> Peer
     (Handshake vNumber Term)
     'AsClient
     'StConfirm
     m
     (Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
forall a b. (a -> b) -> a -> b
$ \Message (Handshake vNumber Term) 'StConfirm st'
msg -> case Message (Handshake vNumber Term) 'StConfirm st'
msg of
      MsgReplyVersions vMap ->
        -- simultaneous open; 'accept' will choose version (the greatest common
        -- version), and check if we can accept received version data.
        NobodyHasAgency 'StDone
-> Either (HandshakeProtocolError vNumber) (r, vNumber, vData)
-> Peer
     (Handshake vNumber Term)
     'AsClient
     'StDone
     m
     (Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
forall ps (st :: ps) a (pr :: PeerRole) (m :: * -> *).
NobodyHasAgency st -> a -> Peer ps pr st m a
Done NobodyHasAgency 'StDone
forall k k (vNumber :: k) (vParams :: k). NobodyHasAgency 'StDone
TokDone (Either (HandshakeProtocolError vNumber) (r, vNumber, vData)
 -> Peer
      (Handshake vNumber Term)
      'AsClient
      'StDone
      m
      (Either (HandshakeProtocolError vNumber) (r, vNumber, vData)))
-> Either (HandshakeProtocolError vNumber) (r, vNumber, vData)
-> Peer
     (Handshake vNumber Term)
     'AsClient
     'StDone
     m
     (Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
forall a b. (a -> b) -> a -> b
$ case VersionDataCodec Term vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Map vNumber Term
-> Either (RefuseReason vNumber) (r, vNumber, vData)
forall vParams vNumber vData r.
Ord vNumber =>
VersionDataCodec vParams vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Map vNumber vParams
-> Either (RefuseReason vNumber) (r, vNumber, vData)
acceptOrRefuse VersionDataCodec Term vNumber vData
codec vData -> vData -> Accept vData
acceptVersion Versions vNumber vData r
versions Map vNumber Term
Map vNumber vParams
vMap of
          Right (r, vNumber, vData)
r      -> (r, vNumber, vData)
-> Either (HandshakeProtocolError vNumber) (r, vNumber, vData)
forall a b. b -> Either a b
Right (r, vNumber, vData)
r
          Left RefuseReason vNumber
vReason -> HandshakeProtocolError vNumber
-> Either (HandshakeProtocolError vNumber) (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)

      -- the server refused common highest version
      MsgRefuse vReason ->
        NobodyHasAgency 'StDone
-> Either (HandshakeProtocolError vNumber) (r, vNumber, vData)
-> Peer
     (Handshake vNumber Term)
     'AsClient
     'StDone
     m
     (Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
forall ps (st :: ps) a (pr :: PeerRole) (m :: * -> *).
NobodyHasAgency st -> a -> Peer ps pr st m a
Done NobodyHasAgency 'StDone
forall k k (vNumber :: k) (vParams :: k). NobodyHasAgency 'StDone
TokDone (HandshakeProtocolError vNumber
-> Either (HandshakeProtocolError vNumber) (r, vNumber, vData)
forall a b. a -> Either a b
Left (HandshakeProtocolError vNumber
 -> Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
-> HandshakeProtocolError vNumber
-> Either (HandshakeProtocolError vNumber) (r, vNumber, vData)
forall a b. (a -> b) -> a -> b
$ RefuseReason vNumber -> HandshakeProtocolError vNumber
forall vNumber.
RefuseReason vNumber -> HandshakeProtocolError vNumber
HandshakeError RefuseReason vNumber
vReason)

      -- the server accepted a version, sent back the version number and its
      -- version data blob
      MsgAcceptVersion vNumber vParams ->
        case vNumber
vNumber vNumber -> Map vNumber (Version vData r) -> Maybe (Version vData r)
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` 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 (Version vData r)
Nothing -> NobodyHasAgency 'StDone
-> Either (HandshakeProtocolError vNumber) (r, vNumber, vData)
-> Peer
     (Handshake vNumber Term)
     'AsClient
     'StDone
     m
     (Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
forall ps (st :: ps) a (pr :: PeerRole) (m :: * -> *).
NobodyHasAgency st -> a -> Peer ps pr st m a
Done NobodyHasAgency 'StDone
forall k k (vNumber :: k) (vParams :: k). NobodyHasAgency 'StDone
TokDone (HandshakeProtocolError vNumber
-> Either (HandshakeProtocolError vNumber) (r, vNumber, vData)
forall a b. a -> Either a b
Left (HandshakeProtocolError vNumber
 -> Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
-> HandshakeProtocolError vNumber
-> Either (HandshakeProtocolError vNumber) (r, vNumber, vData)
forall a b. (a -> b) -> a -> b
$ vNumber -> HandshakeProtocolError vNumber
forall vNumber. vNumber -> HandshakeProtocolError vNumber
NotRecognisedVersion vNumber
vNumber)
          Just (Version vData -> r
app vData
vData) ->
            case vNumber -> Term -> Either Text vData
decodeData vNumber
vNumber
vNumber vParams
Term
vParams of

              Left Text
err ->
                NobodyHasAgency 'StDone
-> Either (HandshakeProtocolError vNumber) (r, vNumber, vData)
-> Peer
     (Handshake vNumber Term)
     'AsClient
     'StDone
     m
     (Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
forall ps (st :: ps) a (pr :: PeerRole) (m :: * -> *).
NobodyHasAgency st -> a -> Peer ps pr st m a
Done NobodyHasAgency 'StDone
forall k k (vNumber :: k) (vParams :: k). NobodyHasAgency 'StDone
TokDone (HandshakeProtocolError vNumber
-> Either (HandshakeProtocolError vNumber) (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
vNumber Text
err))

              Right vData
vData' ->
                case vData -> vData -> Accept vData
acceptVersion vData
vData vData
vData' of
                  Accept vData
agreedData ->
                    NobodyHasAgency 'StDone
-> Either (HandshakeProtocolError vNumber) (r, vNumber, vData)
-> Peer
     (Handshake vNumber Term)
     'AsClient
     'StDone
     m
     (Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
forall ps (st :: ps) a (pr :: PeerRole) (m :: * -> *).
NobodyHasAgency st -> a -> Peer ps pr st m a
Done NobodyHasAgency 'StDone
forall k k (vNumber :: k) (vParams :: k). NobodyHasAgency 'StDone
TokDone (Either (HandshakeProtocolError vNumber) (r, vNumber, vData)
 -> Peer
      (Handshake vNumber Term)
      'AsClient
      'StDone
      m
      (Either (HandshakeProtocolError vNumber) (r, vNumber, vData)))
-> Either (HandshakeProtocolError vNumber) (r, vNumber, vData)
-> Peer
     (Handshake vNumber Term)
     'AsClient
     'StDone
     m
     (Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
forall a b. (a -> b) -> a -> b
$ (r, vNumber, vData)
-> Either (HandshakeProtocolError vNumber) (r, vNumber, vData)
forall a b. b -> Either a b
Right ((r, vNumber, vData)
 -> Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
-> (r, vNumber, vData)
-> Either (HandshakeProtocolError vNumber) (r, vNumber, vData)
forall a b. (a -> b) -> a -> b
$ ( vData -> r
app vData
agreedData
                                           , vNumber
vNumber
                                           , vData
agreedData
                                           )
                  Refuse Text
err ->
                    NobodyHasAgency 'StDone
-> Either (HandshakeProtocolError vNumber) (r, vNumber, vData)
-> Peer
     (Handshake vNumber Term)
     'AsClient
     'StDone
     m
     (Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
forall ps (st :: ps) a (pr :: PeerRole) (m :: * -> *).
NobodyHasAgency st -> a -> Peer ps pr st m a
Done NobodyHasAgency 'StDone
forall k k (vNumber :: k) (vParams :: k). NobodyHasAgency 'StDone
TokDone (HandshakeProtocolError vNumber
-> Either (HandshakeProtocolError vNumber) (r, vNumber, vData)
forall a b. a -> Either a b
Left (vNumber -> Text -> HandshakeProtocolError vNumber
forall vNumber. vNumber -> Text -> HandshakeProtocolError vNumber
InvalidServerSelection vNumber
vNumber Text
err))


encodeVersions
  :: forall vNumber r vParams vData.
     (vNumber -> vData -> vParams)
  -> Versions vNumber vData r
  -> Map vNumber vParams
encodeVersions :: (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 :: forall vData r. Version vData r -> vData
versionData :: vData
versionData} = vNumber -> vData -> vParams
encoder vNumber
vNumber vData
versionData


acceptOrRefuse
  :: forall vParams vNumber vData r.
     Ord vNumber
  => VersionDataCodec vParams vNumber vData
  -> (vData -> vData -> Accept vData)
  -> Versions vNumber vData r
  -> Map vNumber vParams
  -- ^ proposed versions received either with `MsgProposeVersions` or
  -- `MsgReplyVersions`
  -> Either (RefuseReason vNumber) (r, vNumber, vData)
acceptOrRefuse :: VersionDataCodec vParams vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Map vNumber vParams
-> Either (RefuseReason vNumber) (r, vNumber, vData)
acceptOrRefuse VersionDataCodec {vNumber -> vParams -> Either Text vData
decodeData :: vNumber -> vParams -> Either Text vData
decodeData :: forall bytes vNumber vData.
VersionDataCodec bytes vNumber vData
-> vNumber -> bytes -> Either Text vData
decodeData}
               vData -> vData -> Accept vData
acceptVersion Versions vNumber vData r
versions Map vNumber vParams
versionMap =
    case Map vNumber vParams
-> Map vNumber (Version vData r)
-> Maybe (vNumber, (vParams, Version vData r))
forall k a b. Ord k => Map k a -> Map k b -> Maybe (k, (a, b))
lookupGreatestCommonKey Map vNumber vParams
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, (vParams, 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, (vParams
vParams, Version vData -> r
app vData
vData)) ->
        case vNumber -> vParams -> Either Text vData
decodeData vNumber
vNumber vParams
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 :: 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