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

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

import qualified Codec.CBOR.Term as CBOR

import           Network.TypedProtocol.Core

import           Ouroboros.Network.Protocol.Handshake.Client (acceptOrRefuse)
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@.
--
handshakeServerPeer
  :: ( Ord vNumber
     )
  => VersionDataCodec CBOR.Term vNumber vData
  -> (vData -> vData -> Accept vData)
  -> Versions vNumber vData r
  -> Peer (Handshake vNumber CBOR.Term)
          AsServer StPropose m
          (Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
handshakeServerPeer :: VersionDataCodec Term vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Peer
     (Handshake vNumber Term)
     'AsServer
     'StPropose
     m
     (Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
handshakeServerPeer 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} vData -> vData -> Accept vData
acceptVersion Versions vNumber vData r
versions =
    TheyHaveAgency 'AsServer 'StPropose
-> (forall (st' :: Handshake vNumber Term).
    Message (Handshake vNumber Term) 'StPropose st'
    -> Peer
         (Handshake vNumber Term)
         'AsServer
         st'
         m
         (Either (HandshakeProtocolError vNumber) (r, vNumber, vData)))
-> Peer
     (Handshake vNumber Term)
     'AsServer
     'StPropose
     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 (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 Term).
  Message (Handshake vNumber Term) 'StPropose st'
  -> Peer
       (Handshake vNumber Term)
       'AsServer
       st'
       m
       (Either (HandshakeProtocolError vNumber) (r, vNumber, vData)))
 -> Peer
      (Handshake vNumber Term)
      'AsServer
      'StPropose
      m
      (Either (HandshakeProtocolError vNumber) (r, vNumber, vData)))
-> (forall (st' :: Handshake vNumber Term).
    Message (Handshake vNumber Term) 'StPropose st'
    -> Peer
         (Handshake vNumber Term)
         'AsServer
         st'
         m
         (Either (HandshakeProtocolError vNumber) (r, vNumber, vData)))
-> Peer
     (Handshake vNumber Term)
     'AsServer
     'StPropose
     m
     (Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
forall a b. (a -> b) -> a -> b
$ \Message (Handshake vNumber Term) 'StPropose st'
msg -> case Message (Handshake vNumber Term) 'StPropose st'
msg of
      MsgProposeVersions vMap  ->
        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 :: (r, vNumber, vData)
r@(r
_, vNumber
vNumber, vData
agreedData)) ->
            WeHaveAgency 'AsServer 'StConfirm
-> Message (Handshake vNumber Term) 'StConfirm 'StDone
-> Peer
     (Handshake vNumber Term)
     'AsServer
     'StDone
     m
     (Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
-> Peer
     (Handshake vNumber Term)
     'AsServer
     'StConfirm
     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 (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
-> Term -> Message (Handshake vNumber Term) 'StConfirm 'StDone
forall vNumber vNumber.
vNumber
-> vNumber
-> Message (Handshake vNumber vNumber) 'StConfirm 'StDone
MsgAcceptVersion vNumber
vNumber (vNumber -> vData -> Term
encodeData vNumber
vNumber vData
agreedData))
                  (NobodyHasAgency 'StDone
-> Either (HandshakeProtocolError vNumber) (r, vNumber, vData)
-> Peer
     (Handshake vNumber Term)
     'AsServer
     '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 ((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) ->
            WeHaveAgency 'AsServer 'StConfirm
-> Message (Handshake vNumber Term) 'StConfirm 'StDone
-> Peer
     (Handshake vNumber Term)
     'AsServer
     'StDone
     m
     (Either (HandshakeProtocolError vNumber) (r, vNumber, vData))
-> Peer
     (Handshake vNumber Term)
     'AsServer
     'StConfirm
     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 (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 Term) 'StConfirm 'StDone
forall k vNumber (vParams :: k).
RefuseReason vNumber
-> Message (Handshake vNumber vParams) 'StConfirm 'StDone
MsgRefuse RefuseReason vNumber
vReason)
                  (NobodyHasAgency 'StDone
-> Either (HandshakeProtocolError vNumber) (r, vNumber, vData)
-> Peer
     (Handshake vNumber Term)
     'AsServer
     '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
vReason)))