1  {-# LANGUAGE OverloadedStrings #-}
  2  {-# LANGUAGE ScopedTypeVariables #-}
  3  
  4  module Network.Cardano.Mux.TcpSpec (spec) where
  5  
  6  import Test.Hspec
  7  
  8  import Control.Concurrent (forkIO)
  9  import Control.Concurrent.MVar
 10  
 11  import Network.Cardano.Mux.Transport
 12  import Network.Cardano.Mux.Transport.Tcp
 13  import Network.Cardano.Protocol.Handshake
 14  import Network.Cardano.Protocol.Handshake.Codec
 15  import Network.Cardano.Protocol.Handshake.Types
 16  
 17  spec :: Spec
 18  spec = describe "TCP Transport Integration" $ do
 19    describe "Basic Transport" $ do
 20      it "can send and receive data between client and server" $ do
 21        withServer 0 $ \listenSock port -> do
 22          -- Start a thread to accept connection
 23          serverResult <- newEmptyMVar
 24          _ <- forkIO $ do
 25            serverT <- acceptConnection listenSock
 26            -- Read what client sends
 27            mData <- transportRead serverT 13
 28            putMVar serverResult mData
 29            transportClose serverT
 30  
 31          -- Connect as client and send data
 32          clientT <- connectToServer "127.0.0.1" port
 33          transportWrite clientT "Hello, Server"
 34          transportClose clientT
 35  
 36          -- Check server received it
 37          result <- takeMVar serverResult
 38          result `shouldBe` Just "Hello, Server"
 39  
 40      it "handles bidirectional communication" $ do
 41        withServer 0 $ \listenSock port -> do
 42          serverResult <- newEmptyMVar
 43          clientResult <- newEmptyMVar
 44  
 45          -- Server thread
 46          _ <- forkIO $ do
 47            serverT <- acceptConnection listenSock
 48            -- Read from client
 49            mData <- transportRead serverT 5
 50            -- Send response
 51            transportWrite serverT "PONG"
 52            putMVar serverResult mData
 53            transportClose serverT
 54  
 55          -- Client
 56          clientT <- connectToServer "127.0.0.1" port
 57          transportWrite clientT "PING!"
 58          -- Read response
 59          mResp <- transportRead clientT 4
 60          putMVar clientResult mResp
 61          transportClose clientT
 62  
 63          takeMVar serverResult `shouldReturn` Just "PING!"
 64          takeMVar clientResult `shouldReturn` Just "PONG"
 65  
 66    describe "Handshake Protocol over TCP" $ do
 67      it "server-initiator and client-responder complete handshake" $ do
 68        testHandshake ServerInitiator
 69  
 70      it "server-responder and client-initiator complete handshake" $ do
 71        testHandshake ServerResponder
 72  
 73      it "client-initiator and server-responder complete handshake" $ do
 74        -- Same as server-responder, but emphasizing client perspective
 75        testHandshake ClientInitiator
 76  
 77      it "client-responder and server-initiator complete handshake" $ do
 78        -- Same as server-initiator, but emphasizing client perspective
 79        testHandshake ClientResponder
 80  
 81      it "handshake fails when no common version" $ do
 82        testHandshakeNoCommonVersion
 83  
 84  -- | Configuration for which side plays which role
 85  data TestRole
 86    = ServerInitiator  -- Server sends ProposeVersions, Client responds
 87    | ServerResponder  -- Client sends ProposeVersions, Server responds
 88    | ClientInitiator  -- Same as ServerResponder (client initiates)
 89    | ClientResponder  -- Same as ServerInitiator (server initiates)
 90  
 91  -- | Run a handshake test with specified role configuration.
 92  testHandshake :: TestRole -> IO ()
 93  testHandshake role = do
 94    let initiatorConfig = HandshakeConfig
 95          { hcNetworkMagic = 764824073
 96          , hcSupportedVersions = [V10, V11, V12]
 97          , hcInitiatorOnly = False
 98          , hcPeerSharing = PeerSharingDisabled
 99          }
100        responderConfig = HandshakeConfig
101          { hcNetworkMagic = 764824073
102          , hcSupportedVersions = [V10, V11]
103          , hcInitiatorOnly = False
104          , hcPeerSharing = PeerSharingDisabled
105          }
106  
107    withServer 0 $ \listenSock port -> do
108      serverResult <- newEmptyMVar
109      clientResult <- newEmptyMVar
110  
111      case role of
112        ServerInitiator -> do
113          -- Server thread: initiator
114          _ <- forkIO $ do
115            serverT <- acceptConnection listenSock
116            result <- runInitiator serverT initiatorConfig
117            putMVar serverResult result
118            transportClose serverT
119  
120          -- Client: responder
121          clientT <- connectToServer "127.0.0.1" port
122          result <- runResponder clientT responderConfig
123          putMVar clientResult result
124          transportClose clientT
125  
126        ServerResponder -> do
127          -- Server thread: responder
128          _ <- forkIO $ do
129            serverT <- acceptConnection listenSock
130            result <- runResponder serverT responderConfig
131            putMVar serverResult result
132            transportClose serverT
133  
134          -- Client: initiator
135          clientT <- connectToServer "127.0.0.1" port
136          result <- runInitiator clientT initiatorConfig
137          putMVar clientResult result
138          transportClose clientT
139  
140        ClientInitiator -> do
141          -- Same as ServerResponder
142          _ <- forkIO $ do
143            serverT <- acceptConnection listenSock
144            result <- runResponder serverT responderConfig
145            putMVar serverResult result
146            transportClose serverT
147  
148          clientT <- connectToServer "127.0.0.1" port
149          result <- runInitiator clientT initiatorConfig
150          putMVar clientResult result
151          transportClose clientT
152  
153        ClientResponder -> do
154          -- Same as ServerInitiator
155          _ <- forkIO $ do
156            serverT <- acceptConnection listenSock
157            result <- runInitiator serverT initiatorConfig
158            putMVar serverResult result
159            transportClose serverT
160  
161          clientT <- connectToServer "127.0.0.1" port
162          result <- runResponder clientT responderConfig
163          putMVar clientResult result
164          transportClose clientT
165  
166      sRes <- takeMVar serverResult
167      cRes <- takeMVar clientResult
168  
169      -- Both should succeed with V11 (highest common version)
170      case (sRes, cRes) of
171        (Right sHr, Right cHr) -> do
172          hrVersion sHr `shouldBe` V11
173          hrVersion cHr `shouldBe` V11
174        (Left err, _) -> expectationFailure $ "Server failed: " ++ show err
175        (_, Left err) -> expectationFailure $ "Client failed: " ++ show err
176  
177  -- | Test that handshake fails when there's no common version.
178  testHandshakeNoCommonVersion :: IO ()
179  testHandshakeNoCommonVersion = do
180    let initiatorConfig = HandshakeConfig
181          { hcNetworkMagic = 764824073
182          , hcSupportedVersions = [V7, V8]
183          , hcInitiatorOnly = False
184          , hcPeerSharing = PeerSharingDisabled
185          }
186        responderConfig = HandshakeConfig
187          { hcNetworkMagic = 764824073
188          , hcSupportedVersions = [V11, V12, V13]
189          , hcInitiatorOnly = False
190          , hcPeerSharing = PeerSharingDisabled
191          }
192  
193    withServer 0 $ \listenSock port -> do
194      serverResult <- newEmptyMVar
195      clientResult <- newEmptyMVar
196  
197      -- Server: responder
198      _ <- forkIO $ do
199        serverT <- acceptConnection listenSock
200        result <- runResponder serverT responderConfig
201        putMVar serverResult result
202        transportClose serverT
203  
204      -- Client: initiator
205      clientT <- connectToServer "127.0.0.1" port
206      result <- runInitiator clientT initiatorConfig
207      putMVar clientResult result
208      transportClose clientT
209  
210      sRes <- takeMVar serverResult
211      cRes <- takeMVar clientResult
212  
213      -- Initiator should get refused, responder reports no common version
214      case (cRes, sRes) of
215        (Left (HandshakeRefused (RefuseVersionMismatch _)), Left HandshakeNoCommonVersion) ->
216          pure ()  -- Expected
217        (cR, sR) ->
218          expectationFailure $ "Expected version mismatch, got client: " ++
219            show cR ++ ", server: " ++ show sR
220  
221  -- | Run the initiator side of the handshake over a transport.
222  runInitiator :: TcpTransport -> HandshakeConfig -> IO (Either HandshakeError HandshakeResult)
223  runInitiator t config = do
224    -- Send ProposeVersions
225    let versions = buildVersionTable config
226        msg = MsgProposeVersions versions
227    transportWrite t (encodeHandshake msg)
228  
229    -- Receive response
230    mResponse <- transportRead t 4096
231    case mResponse of
232      Nothing -> pure $ Left $ HandshakeUnexpectedMessage "Connection closed"
233      Just bs -> do
234        case decodeHandshake bs of
235          Left err -> pure $ Left $ HandshakeUnexpectedMessage err
236          Right (MsgAcceptVersion ver vdata) ->
237            pure $ Right $ HandshakeResult ver vdata
238          Right (MsgRefuse reason) ->
239            pure $ Left $ HandshakeRefused reason
240          Right other ->
241            pure $ Left $ HandshakeUnexpectedMessage $ "Unexpected: " ++ show other
242  
243  -- | Run the responder side of the handshake over a transport.
244  runResponder :: TcpTransport -> HandshakeConfig -> IO (Either HandshakeError HandshakeResult)
245  runResponder t config = do
246    -- Receive ProposeVersions
247    mPropose <- transportRead t 4096
248    case mPropose of
249      Nothing -> pure $ Left $ HandshakeUnexpectedMessage "Connection closed"
250      Just bs -> do
251        case decodeHandshake bs of
252          Left err -> pure $ Left $ HandshakeUnexpectedMessage err
253          Right (MsgProposeVersions theirVersions) -> do
254            -- Find compatible version
255            case findCompatibleVersion config theirVersions of
256              Nothing -> do
257                -- Send refuse
258                let refuse = MsgRefuse $ RefuseVersionMismatch (hcSupportedVersions config)
259                transportWrite t (encodeHandshake refuse)
260                pure $ Left HandshakeNoCommonVersion
261              Just (ver, _theirData) -> do
262                -- Accept with our version data
263                let ourData = buildVersionData config ver
264                    accept = MsgAcceptVersion ver ourData
265                transportWrite t (encodeHandshake accept)
266                pure $ Right $ HandshakeResult ver ourData
267          Right other ->
268            pure $ Left $ HandshakeUnexpectedMessage $ "Expected ProposeVersions, got: " ++ show other