1  {-# LANGUAGE OverloadedStrings #-}
  2  {-# LANGUAGE RankNTypes #-}
  3  
  4  module Network.Cardano.Protocol.Handshake
  5    ( -- * Configuration and results
  6      HandshakeConfig (..)
  7    , HandshakeResult (..)
  8    , HandshakeError (..)
  9  
 10      -- * Protocol implementations
 11    , handshakeInitiator
 12    , handshakeResponder
 13  
 14      -- * Helpers
 15    , buildVersionTable
 16    , buildVersionData
 17    , findCompatibleVersion
 18    ) where
 19  
 20  import Data.ByteString (ByteString)
 21  import Data.Map.Strict (Map)
 22  import qualified Data.Map.Strict as Map
 23  import qualified Data.Set as Set
 24  
 25  import Hyper (Co, yieldC)
 26  import Network.Cardano.Protocol.Handshake.Codec
 27  import Network.Cardano.Protocol.Handshake.Types
 28  
 29  -- | Handshake protocol as initiator.
 30  --
 31  -- The initiator:
 32  -- 1. Sends MsgProposeVersions with supported versions
 33  -- 2. Waits for MsgAcceptVersion or MsgRefuse
 34  --
 35  -- Returns the negotiated version or an error.
 36  handshakeInitiator
 37    :: (Monad m)
 38    => HandshakeConfig
 39    -> Co r ByteString ByteString m (Either HandshakeError HandshakeResult)
 40  handshakeInitiator config = do
 41    -- Step 1: Send ProposeVersions
 42    let versions = buildVersionTable config
 43        proposal = MsgProposeVersions versions
 44    response <- yieldC (encodeHandshake proposal)
 45  
 46    -- Step 2: Process response
 47    pure $ case decodeHandshake response of
 48      Left err ->
 49        Left $ HandshakeDecodeError err
 50  
 51      Right (MsgAcceptVersion ver vdata) ->
 52        Right $ HandshakeResult ver vdata
 53  
 54      Right (MsgRefuse reason) ->
 55        Left $ HandshakeRefused reason
 56  
 57      Right (MsgQueryReply _) ->
 58        Left $ HandshakeUnexpectedMessage "Unexpected MsgQueryReply to proposal"
 59  
 60      Right (MsgProposeVersions _) ->
 61        Left $ HandshakeUnexpectedMessage "Unexpected MsgProposeVersions in response"
 62  
 63  -- | Handshake protocol as responder.
 64  --
 65  -- The responder:
 66  -- 1. Waits for MsgProposeVersions
 67  -- 2. Sends MsgAcceptVersion (if compatible) or MsgRefuse
 68  --
 69  -- Returns the negotiated version or an error.
 70  handshakeResponder
 71    :: (Monad m)
 72    => HandshakeConfig
 73    -> Co r ByteString ByteString m (Either HandshakeError HandshakeResult)
 74  handshakeResponder config = do
 75    -- Step 1: Wait for ProposeVersions by yielding an empty marker
 76    -- (The first yield gets us into the coroutine, the response will be the proposal)
 77    -- We use a trick: yield an empty response first, which the mux will discard,
 78    -- then we get the actual proposal as our "response"
 79    -- Actually, the responder needs to receive first. Let's model this differently:
 80    -- The responder yields its initial "nothing" and gets back the proposal.
 81    incoming <- yieldC mempty
 82  
 83    case decodeHandshake incoming of
 84      Left err -> do
 85        -- Send decode error refuse and return error
 86        let refuse = MsgRefuse $ RefuseHandshakeDecodeError V7 "Decode error"
 87        _ <- yieldC (encodeHandshake refuse)
 88        pure $ Left $ HandshakeDecodeError err
 89  
 90      Right (MsgProposeVersions theirVersions) -> do
 91        -- Step 2: Find compatible version
 92        case findCompatibleVersion config theirVersions of
 93          Nothing -> do
 94            -- No common version, send refuse
 95            let refuse = MsgRefuse $ RefuseVersionMismatch (hcSupportedVersions config)
 96            _ <- yieldC (encodeHandshake refuse)
 97            pure $ Left HandshakeNoCommonVersion
 98  
 99          Just (ver, ourData) -> do
100            -- Accept the version
101            let accept = MsgAcceptVersion ver ourData
102            _ <- yieldC (encodeHandshake accept)
103            -- Return our data as result (in real impl we'd use their data)
104            pure $ Right $ HandshakeResult ver ourData
105  
106      Right other -> do
107        let refuse = MsgRefuse $ RefuseRefused V7 "Unexpected message type"
108        _ <- yieldC (encodeHandshake refuse)
109        pure $ Left $ HandshakeUnexpectedMessage $ "Expected MsgProposeVersions, got: " ++ show other
110  
111  -- | Build a version table from configuration.
112  buildVersionTable :: HandshakeConfig -> Map VersionNumber VersionData
113  buildVersionTable config =
114    Map.fromList [(v, buildVersionData config v) | v <- hcSupportedVersions config]
115  
116  -- | Build version data for a specific version.
117  buildVersionData :: HandshakeConfig -> VersionNumber -> VersionData
118  buildVersionData config ver
119    | ver <= V10 = VersionDataV7_10
120        { vdNetworkMagic  = hcNetworkMagic config
121        , vdInitiatorOnly = hcInitiatorOnly config
122        }
123    | otherwise = VersionDataV11_13
124        { vdNetworkMagic'  = hcNetworkMagic config
125        , vdInitiatorOnly' = hcInitiatorOnly config
126        , vdPeerSharing    = hcPeerSharing config
127        , vdQuery          = False
128        }
129  
130  -- | Find the highest mutually supported version.
131  findCompatibleVersion
132    :: HandshakeConfig
133    -> Map VersionNumber VersionData
134    -> Maybe (VersionNumber, VersionData)
135  findCompatibleVersion config theirVersions =
136    let ours   = Set.fromList (hcSupportedVersions config)
137        theirs = Map.keysSet theirVersions
138        common = Set.intersection ours theirs
139    in if Set.null common
140         then Nothing
141         else let ver = Set.findMax common
142              in Just (ver, buildVersionData config ver)