{-# 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
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 =
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 ->
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
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
))
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