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

module Ouroboros.Network.Protocol.Handshake.Server
  ( handshakeServerPeer
  ) where

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

import           Network.TypedProtocol.Core

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


-- | Server following the handshake protocol; it accepts highest version offered
-- by the peer that also belongs to the server @versions@.
--
-- TODO: GADT encoding of the server (@Handshake.Server@ module).
--
handshakeServerPeer
  :: Ord vNumber
  => VersionDataCodec vParams vNumber vData
  -> (vData -> vData -> Accept vData)
  -> Versions vNumber vData r
  -> Peer (Handshake vNumber vParams)
          AsServer StPropose m
          (Either (RefuseReason vNumber) (r, vNumber, vData))
handshakeServerPeer :: VersionDataCodec vParams vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Peer
     (Handshake vNumber vParams)
     'AsServer
     'StPropose
     m
     (Either (RefuseReason vNumber) (r, vNumber, vData))
handshakeServerPeer VersionDataCodec {vNumber -> vData -> vParams
encodeData :: forall bytes vNumber vData.
VersionDataCodec bytes vNumber vData -> vNumber -> vData -> bytes
encodeData :: vNumber -> vData -> vParams
encodeData, vNumber -> vParams -> Either Text vData
decodeData :: forall bytes vNumber vData.
VersionDataCodec bytes vNumber vData
-> vNumber -> bytes -> Either Text vData
decodeData :: vNumber -> vParams -> Either Text vData
decodeData} vData -> vData -> Accept vData
acceptVersion Versions vNumber vData r
versions =
    -- await for versions proposed by a client
    TheyHaveAgency 'AsServer 'StPropose
-> (forall (st' :: Handshake vNumber vParams).
    Message (Handshake vNumber vParams) 'StPropose st'
    -> Peer
         (Handshake vNumber vParams)
         'AsServer
         st'
         m
         (Either (RefuseReason vNumber) (r, vNumber, vData)))
-> Peer
     (Handshake vNumber vParams)
     'AsServer
     'StPropose
     m
     (Either (RefuseReason 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 (ClientHasAgency 'StPropose -> PeerHasAgency 'AsClient 'StPropose
forall ps (st :: ps).
ClientHasAgency st -> PeerHasAgency 'AsClient st
ClientAgency ClientHasAgency 'StPropose
forall k k (vNumber :: k) (vParams :: k).
ClientHasAgency 'StPropose
TokPropose) ((forall (st' :: Handshake vNumber vParams).
  Message (Handshake vNumber vParams) 'StPropose st'
  -> Peer
       (Handshake vNumber vParams)
       'AsServer
       st'
       m
       (Either (RefuseReason vNumber) (r, vNumber, vData)))
 -> Peer
      (Handshake vNumber vParams)
      'AsServer
      'StPropose
      m
      (Either (RefuseReason vNumber) (r, vNumber, vData)))
-> (forall (st' :: Handshake vNumber vParams).
    Message (Handshake vNumber vParams) 'StPropose st'
    -> Peer
         (Handshake vNumber vParams)
         'AsServer
         st'
         m
         (Either (RefuseReason vNumber) (r, vNumber, vData)))
-> Peer
     (Handshake vNumber vParams)
     'AsServer
     'StPropose
     m
     (Either (RefuseReason vNumber) (r, vNumber, vData))
forall a b. (a -> b) -> a -> b
$ \Message (Handshake vNumber vParams) 'StPropose st'
msg -> case Message (Handshake vNumber vParams) 'StPropose st'
msg of

      MsgProposeVersions vMap ->
        -- Compute intersection of local and remote versions.
        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
vMap (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 ->
            let vReason :: RefuseReason vNumber
vReason = [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) []
            in WeHaveAgency 'AsServer 'StConfirm
-> Message (Handshake vNumber vParams) 'StConfirm 'StDone
-> Peer
     (Handshake vNumber vParams)
     'AsServer
     'StDone
     m
     (Either (RefuseReason vNumber) (r, vNumber, vData))
-> Peer
     (Handshake vNumber vParams)
     'AsServer
     'StConfirm
     m
     (Either (RefuseReason 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 (ServerHasAgency 'StConfirm -> WeHaveAgency 'AsServer 'StConfirm
forall ps (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
ServerAgency ServerHasAgency 'StConfirm
forall k k (vNumber :: k) (vParams :: k).
ServerHasAgency 'StConfirm
TokConfirm)
                     (RefuseReason vNumber
-> Message (Handshake vNumber vParams) 'StConfirm 'StDone
forall k vParams (vParams :: k).
RefuseReason vParams
-> Message (Handshake vParams vParams) 'StConfirm 'StDone
MsgRefuse RefuseReason vNumber
vReason)
                     (NobodyHasAgency 'StDone
-> Either (RefuseReason vNumber) (r, vNumber, vData)
-> Peer
     (Handshake vNumber vParams)
     'AsServer
     'StDone
     m
     (Either (RefuseReason 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 (RefuseReason vNumber
-> Either (RefuseReason vNumber) (r, vNumber, vData)
forall a b. a -> Either a b
Left RefuseReason vNumber
vReason))

          Just (vNumber
vNumber, (vParams
vParams, Version Application vData r
app vData
vData)) ->
              case vNumber -> vParams -> Either Text vData
decodeData vNumber
vNumber
vNumber vParams
vParams
vParams of
                Left Text
err ->
                  let vReason :: RefuseReason vNumber
vReason = vNumber -> Text -> RefuseReason vNumber
forall vNumber. vNumber -> Text -> RefuseReason vNumber
HandshakeDecodeError vNumber
vNumber Text
err
                  in WeHaveAgency 'AsServer 'StConfirm
-> Message (Handshake vNumber vParams) 'StConfirm 'StDone
-> Peer
     (Handshake vNumber vParams)
     'AsServer
     'StDone
     m
     (Either (RefuseReason vNumber) (r, vNumber, vData))
-> Peer
     (Handshake vNumber vParams)
     'AsServer
     'StConfirm
     m
     (Either (RefuseReason 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 (ServerHasAgency 'StConfirm -> WeHaveAgency 'AsServer 'StConfirm
forall ps (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
ServerAgency ServerHasAgency 'StConfirm
forall k k (vNumber :: k) (vParams :: k).
ServerHasAgency 'StConfirm
TokConfirm)
                           (RefuseReason vNumber
-> Message (Handshake vNumber vParams) 'StConfirm 'StDone
forall k vParams (vParams :: k).
RefuseReason vParams
-> Message (Handshake vParams vParams) 'StConfirm 'StDone
MsgRefuse RefuseReason vNumber
vReason)
                           (NobodyHasAgency 'StDone
-> Either (RefuseReason vNumber) (r, vNumber, vData)
-> Peer
     (Handshake vNumber vParams)
     'AsServer
     'StDone
     m
     (Either (RefuseReason 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 (RefuseReason vNumber) (r, vNumber, vData)
 -> Peer
      (Handshake vNumber vParams)
      'AsServer
      'StDone
      m
      (Either (RefuseReason vNumber) (r, vNumber, vData)))
-> Either (RefuseReason vNumber) (r, vNumber, vData)
-> Peer
     (Handshake vNumber vParams)
     'AsServer
     'StDone
     m
     (Either (RefuseReason vNumber) (r, vNumber, vData))
forall a b. (a -> b) -> a -> b
$ RefuseReason vNumber
-> Either (RefuseReason vNumber) (r, vNumber, vData)
forall a b. a -> Either a b
Left RefuseReason vNumber
vReason)

                Right vData
vData' ->
                  case vData -> vData -> Accept vData
acceptVersion vData
vData vData
vData' of

                    -- We agree on the version; send back the agreed version
                    -- number @vNumber@ and encoded data associated with our
                    -- version.
                    Accept vData
agreedData ->
                      WeHaveAgency 'AsServer 'StConfirm
-> Message (Handshake vNumber vParams) 'StConfirm 'StDone
-> Peer
     (Handshake vNumber vParams)
     'AsServer
     'StDone
     m
     (Either (RefuseReason vNumber) (r, vNumber, vData))
-> Peer
     (Handshake vNumber vParams)
     'AsServer
     'StConfirm
     m
     (Either (RefuseReason 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 (ServerHasAgency 'StConfirm -> WeHaveAgency 'AsServer 'StConfirm
forall ps (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
ServerAgency ServerHasAgency 'StConfirm
forall k k (vNumber :: k) (vParams :: k).
ServerHasAgency 'StConfirm
TokConfirm)
                            (vNumber
-> vParams
-> Message (Handshake vNumber vParams) 'StConfirm 'StDone
forall vNumber vParams.
vNumber
-> vParams
-> Message (Handshake vNumber vParams) 'StConfirm 'StDone
MsgAcceptVersion vNumber
vNumber (vNumber -> vData -> vParams
encodeData vNumber
vNumber
vNumber vData
agreedData))
                            (NobodyHasAgency 'StDone
-> Either (RefuseReason vNumber) (r, vNumber, vData)
-> Peer
     (Handshake vNumber vParams)
     'AsServer
     'StDone
     m
     (Either (RefuseReason 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 (RefuseReason vNumber) (r, vNumber, vData)
 -> Peer
      (Handshake vNumber vParams)
      'AsServer
      'StDone
      m
      (Either (RefuseReason vNumber) (r, vNumber, vData)))
-> Either (RefuseReason vNumber) (r, vNumber, vData)
-> Peer
     (Handshake vNumber vParams)
     'AsServer
     'StDone
     m
     (Either (RefuseReason vNumber) (r, vNumber, vData))
forall a b. (a -> b) -> a -> b
$ (r, vNumber, vData)
-> Either (RefuseReason vNumber) (r, vNumber, vData)
forall a b. b -> Either a b
Right ((r, vNumber, vData)
 -> Either (RefuseReason vNumber) (r, vNumber, vData))
-> (r, vNumber, vData)
-> Either (RefuseReason vNumber) (r, vNumber, vData)
forall a b. (a -> b) -> a -> b
$
                              ( Application vData r -> vData -> r
forall vData r. Application vData r -> vData -> r
runApplication Application vData r
app vData
agreedData
                              , vNumber
vNumber
                              , vData
agreedData
                              ))

                    -- We disagree on the version.
                    Refuse Text
err ->
                      let vReason :: RefuseReason vNumber
vReason = vNumber -> Text -> RefuseReason vNumber
forall vNumber. vNumber -> Text -> RefuseReason vNumber
Refused vNumber
vNumber Text
err
                      in WeHaveAgency 'AsServer 'StConfirm
-> Message (Handshake vNumber vParams) 'StConfirm 'StDone
-> Peer
     (Handshake vNumber vParams)
     'AsServer
     'StDone
     m
     (Either (RefuseReason vNumber) (r, vNumber, vData))
-> Peer
     (Handshake vNumber vParams)
     'AsServer
     'StConfirm
     m
     (Either (RefuseReason 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 (ServerHasAgency 'StConfirm -> WeHaveAgency 'AsServer 'StConfirm
forall ps (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
ServerAgency ServerHasAgency 'StConfirm
forall k k (vNumber :: k) (vParams :: k).
ServerHasAgency 'StConfirm
TokConfirm)
                               (RefuseReason vNumber
-> Message (Handshake vNumber vParams) 'StConfirm 'StDone
forall k vParams (vParams :: k).
RefuseReason vParams
-> Message (Handshake vParams vParams) 'StConfirm 'StDone
MsgRefuse RefuseReason vNumber
vReason)
                               (NobodyHasAgency 'StDone
-> Either (RefuseReason vNumber) (r, vNumber, vData)
-> Peer
     (Handshake vNumber vParams)
     'AsServer
     'StDone
     m
     (Either (RefuseReason 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 (RefuseReason vNumber) (r, vNumber, vData)
 -> Peer
      (Handshake vNumber vParams)
      'AsServer
      'StDone
      m
      (Either (RefuseReason vNumber) (r, vNumber, vData)))
-> Either (RefuseReason vNumber) (r, vNumber, vData)
-> Peer
     (Handshake vNumber vParams)
     'AsServer
     'StDone
     m
     (Either (RefuseReason vNumber) (r, vNumber, vData))
forall a b. (a -> b) -> a -> b
$ 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
$ RefuseReason vNumber
vReason)

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