@@ -275,6 +275,12 @@ data ValidLocalEndPointState = ValidLocalEndPointState
275-- closed; that is, we shouldn't do any 'send's on it (although 'recv' is
275-- closed; that is, we shouldn't do any 'send's on it (although 'recv' is
276-- acceptable, of course -- as we are waiting for the remote endpoint to
276-- acceptable, of course -- as we are waiting for the remote endpoint to
277-- confirm or deny the request).
277-- confirm or deny the request).
279+-- INV-LOCK-ORDER: Remote endpoint must be locked before their local endpoints.
280+-- In other words: it is okay to call modifyMVar on a local endpoint inside a
281+-- modifyMVar on a remote endpoint, but not the other way around. In
282+-- particular, it is okay to call removeRemoteEndPoint inside
283+-- modifyRemoteState.
279data RemoteEndPoint = RemoteEndPoint
285data RemoteEndPoint = RemoteEndPoint
280 { remoteAddress :: EndPointAddress
286 { remoteAddress :: EndPointAddress
@@ -285,7 +291,7 @@ data RemoteEndPoint = RemoteEndPoint
285data RemoteState =
291data RemoteState =
286 RemoteEndPointInvalid (TransportError ConnectErrorCode)
292 RemoteEndPointInvalid (TransportError ConnectErrorCode)
287 | RemoteEndPointValid ValidRemoteEndPointState
293 | RemoteEndPointValid ValidRemoteEndPointState
288− | RemoteEndPointClosing (MVar ()) ValidRemoteEndPointState
294+ | RemoteEndPointClosing (MVar ()) ValidRemoteEndPointState
289 | RemoteEndPointClosed
295 | RemoteEndPointClosed
291data ValidRemoteEndPointState = ValidRemoteEndPointState
297data ValidRemoteEndPointState = ValidRemoteEndPointState
@@ -479,7 +485,7 @@ apiSend (ourEndPoint, theirEndPoint) connId connAlive payload =
479 liftM join . try . mapIOException sendFailed $
485 liftM join . try . mapIOException sendFailed $
480 withRemoteState (ourEndPoint, theirEndPoint) RemoteStatePatternMatch
486 withRemoteState (ourEndPoint, theirEndPoint) RemoteStatePatternMatch
481 { caseInvalid = \_ ->
487 { caseInvalid = \_ ->
482− fail "apiSend RELY violation"
488+ relyViolation (ourEndPoint, theirEndPoint) "apiSend"
483 , caseValid = \vst -> do
489 , caseValid = \vst -> do
484 alive <- readIORef connAlive
490 alive <- readIORef connAlive
485 if alive
491 if alive
@@ -533,6 +539,7 @@ apiCloseEndPoint transport evs ourEndPoint = do
533 tryCloseSocket (remoteSocket conn)
539 tryCloseSocket (remoteSocket conn)
534 return RemoteEndPointClosed
540 return RemoteEndPointClosed
535 RemoteEndPointClosing _ conn -> do
541 RemoteEndPointClosing _ conn -> do
542+ -- TODO: should we signal on resolved here?
536 tryCloseSocket (remoteSocket conn)
543 tryCloseSocket (remoteSocket conn)
537 return RemoteEndPointClosed
544 return RemoteEndPointClosed
538 RemoteEndPointClosed ->
545 RemoteEndPointClosed ->
@@ -939,9 +946,9 @@ doRemoteRequest (ourEndPoint, theirEndPoint) header = do
939 LocalEndPointClosed ->
946 LocalEndPointClosed ->
940 throwIO (userError "Local endpoint closed")
947 throwIO (userError "Local endpoint closed")
941 withRemoteState (ourEndPoint, theirEndPoint) RemoteStatePatternMatch
948 withRemoteState (ourEndPoint, theirEndPoint) RemoteStatePatternMatch
942− { caseInvalid = \_ -> fail "doRemoteRequest RELY violation"
949+ { caseInvalid = \_ -> relyViolation (ourEndPoint, theirEndPoint) "doRemoteRequest"
943 , caseValid = \vst -> sendOn vst [encodeInt32 header, encodeInt32 reqId]
950 , caseValid = \vst -> sendOn vst [encodeInt32 header, encodeInt32 reqId]
944− , caseClosing = \_ -> fail "doRemoteRequest RELY violation"
951+ , caseClosing = \_ _ -> relyViolation (ourEndPoint, theirEndPoint) "doRemoteRequest"
945 , caseClosed = throwIO (userError "Remote endpoint closed")
952 , caseClosed = throwIO (userError "Remote endpoint closed")
947 takeMVar reply
954 takeMVar reply
@@ -955,7 +962,7 @@ closeIfUnused (ourEndPoint, theirEndPoint) =
956 sendOn vst [encodeInt32 CloseSocket]
963 sendOn vst [encodeInt32 CloseSocket]
957 resolved <- newEmptyMVar
964 resolved <- newEmptyMVar
958− return $ RemoteEndPointClosing resolved vst
965+ return $ RemoteEndPointClosing resolved vst
960 return $ RemoteEndPointValid vst
967 return $ RemoteEndPointValid vst
@@ -1065,38 +1072,14 @@ modifyRemoteState (ourEndPoint, theirEndPoint) match =
1065 handleException :: SomeException -> ValidRemoteEndPointState -> IO a
1072 handleException :: SomeException -> ValidRemoteEndPointState -> IO a
1066 handleException ex vst = do
1073 handleException ex vst = do
1067 tryCloseSocket (remoteSocket vst)
1074 tryCloseSocket (remoteSocket vst)
1068− -- We need to remove the remote endpoint from the local endpoint before
1069− -- putting it in Closed state (by INV-CLOSE), but we don't want to hold
1070− -- two locks at the same time. So we put it in closing state first ..
1071− resolved <- newEmptyMVar
1072− putMVar theirState (RemoteEndPointClosing resolved vst)
1073− -- .. then remove it from the local endpoint ..
1074 removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1075 removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1075− -- .. close it and notify the local endpoint we lost the connection ..
1076+ putMVar theirState RemoteEndPointClosed
1076− mIncoming <- closeRemoteEndPoint
1077+ let incoming = IntSet.elems $ vst ^. remoteIncoming
1077− forM_ mIncoming $ \incoming -> do
1078− let code = EventConnectionLost (remoteAddress theirEndPoint) incoming
1078+ code = EventConnectionLost (remoteAddress theirEndPoint) incoming
1079− err = TransportError code (show ex)
1079+ err = TransportError code (show ex)
1080− writeChan (localChannel ourEndPoint) $ ErrorEvent err
1080+ writeChan (localChannel ourEndPoint) $ ErrorEvent err
1081− -- .. and finally rethrow the exception
1082 throwIO ex
1081 throwIO ex
1084− -- Returns the set of incoming connections if we closed the connection, or
1085− -- 'Nothing' if the endpoint was already closed
1086− closeRemoteEndPoint :: IO (Maybe [ConnectionId])
1087− closeRemoteEndPoint = do
1088− st <- takeMVar theirState
1090− RemoteEndPointClosing resolved vst -> do
1091− putMVar resolved ()
1092− putMVar theirState RemoteEndPointClosed
1093− return . Just . IntSet.elems $ vst ^. remoteIncoming
1094− RemoteEndPointClosed -> do
1095− putMVar theirState RemoteEndPointClosed
1098− fail "the impossible happened"
1100-- | Like 'modifyRemoteState' but without a return value
1083-- | Like 'modifyRemoteState' but without a return value
1101modifyRemoteState_ :: EndPointPair
1084modifyRemoteState_ :: EndPointPair
1102 -> RemoteStatePatternMatch RemoteState
1085 -> RemoteStatePatternMatch RemoteState
@@ -1211,25 +1194,39 @@ handleConnectionRequest transport sock = handle handleException $ do
1212-- Returns only if the remote party closes the socket or if an error occurs.
1195-- Returns only if the remote party closes the socket or if an error occurs.
1214−-- RELY: The remote endpoint must be in RemoteEndPointValid or
1197+-- RELY: The remote endpoint must not be invalid.
1215−-- RemoteEndPointClosing state. If the latter, then the 'resolved' MVar
1216−-- associated with the closing state must be empty.
1217-- GUARANTEE: May change the remote endpoint to RemoteEndPointClosed state.
1198-- GUARANTEE: May change the remote endpoint to RemoteEndPointClosed state.
1218handleIncomingMessages :: EndPointPair -> IO ()
1199handleIncomingMessages :: EndPointPair -> IO ()
1219handleIncomingMessages (ourEndPoint, theirEndPoint) = do
1200handleIncomingMessages (ourEndPoint, theirEndPoint) = do
1220− -- For efficiency sake we get the socket once and for all
1221− sock <- withMVar theirState $ \st ->
1201+ mSock <- withMVar theirState $ \st ->
1222 case st of
1202 case st of
1203+ RemoteEndPointInvalid _ ->
1204+ relyViolation (ourEndPoint, theirEndPoint) "handleIncomingMessages:initialization"
1223 RemoteEndPointValid ep ->
1205 RemoteEndPointValid ep ->
1224− return (remoteSocket ep)
1206+ return . Just $ remoteSocket ep
1225 RemoteEndPointClosing _ ep ->
1207 RemoteEndPointClosing _ ep ->
1226− return (remoteSocket ep)
1208+ return . Just $ remoteSocket ep
1227− _ ->
1209+ RemoteEndPointClosed ->
1228− error "handleIncomingMessages RELY violation"
1210+ -- The remote endpoint got closed before we got a chance to start
1229−
1211+ -- dealing with incoming messages
1214+ forM_ mSock $ \sock ->
1230− tryIO (go sock) >>= either (prematureExit sock) return
1215+ tryIO (go sock) >>= either (prematureExit sock) return
1232 -- Dispatch
1217 -- Dispatch
1219+ -- If a recv throws an exception this will be caught top-level and
1220+ -- 'prematureExit' will be invoked. The same will happen if the remote
1221+ -- endpoint is put into a Closed (or Closing) state by a concurrent thread
1222+ -- (because a 'send' failed) -- the individual handlers below will throw a
1223+ -- user exception which is then caught and handled the same way as an
1224+ -- exception thrown by 'recv'.
1226+ -- Note: modifyRemoteState closes the socket before putting the remote
1227+ -- endpoint in closing state, so it is not possible that modifyRemoteState
1228+ -- puts the remote endpoint in Closing state only for it to be reset to
1229+ -- Valid by the RequestConnectionId handler below.
1233 go :: N.Socket -> IO ()
1230 go :: N.Socket -> IO ()
1234 go sock = do
1231 go sock = do
1235 connId <- recvInt32 sock
1232 connId <- recvInt32 sock
@@ -1262,6 +1259,8 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do
1262 newId <- getNextConnectionId ourEndPoint
1259 newId <- getNextConnectionId ourEndPoint
1263 modifyMVar_ theirState $ \st -> do
1260 modifyMVar_ theirState $ \st -> do
1264 vst <- case st of
1261 vst <- case st of
1262+ RemoteEndPointInvalid _ ->
1263+ relyViolation (ourEndPoint, theirEndPoint) "handleIncomingMessages:createNewConnection"
1265 RemoteEndPointValid vst ->
1264 RemoteEndPointValid vst ->
1266 return (remoteIncoming ^: IntSet.insert newId $ vst)
1265 return (remoteIncoming ^: IntSet.insert newId $ vst)
1267 RemoteEndPointClosing resolved vst -> do
1266 RemoteEndPointClosing resolved vst -> do
@@ -1273,8 +1272,8 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do
1273 -- to RemoteEndPointValid
1272 -- to RemoteEndPointValid
1274 putMVar resolved ()
1273 putMVar resolved ()
1275 return (remoteIncoming ^= IntSet.singleton newId $ vst)
1274 return (remoteIncoming ^= IntSet.singleton newId $ vst)
1276− _ ->
1275+ RemoteEndPointClosed ->
1277− error "handleIncomingMessages RELY violation"
1276+ throw $ userError "Remote endpoint closed"
1278 sendOn vst ( encodeInt32 ControlResponse
1277 sendOn vst ( encodeInt32 ControlResponse
1279 : encodeInt32 reqId
1278 : encodeInt32 reqId
1280 : prependLength [encodeInt32 newId]
1279 : prependLength [encodeInt32 newId]
@@ -1309,23 +1308,33 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do
1309 -- because otherwise we should not decrement the reference count
1308 -- because otherwise we should not decrement the reference count
1310 closeConnection :: ConnectionId -> IO ()
1309 closeConnection :: ConnectionId -> IO ()
1311 closeConnection cid = do
1310 closeConnection cid = do
1311+ modifyMVar_ theirState $ \st -> case st of
1312+ RemoteEndPointInvalid _ ->
1313+ relyViolation (ourEndPoint, theirEndPoint) "closeConnection"
1312− modifyMVar_ theirState $ \(RemoteEndPointValid vst) -> do
1314+ RemoteEndPointValid vst -> do
1313− unless (IntSet.member cid (vst ^. remoteIncoming)) $
1315+ unless (IntSet.member cid (vst ^. remoteIncoming)) $
1314− throwIO $ userError "Invalid CloseConnection"
1316+ throwIO $ userError "Invalid CloseConnection"
1315− return ( RemoteEndPointValid
1317+ return ( RemoteEndPointValid
1316− . (remoteIncoming ^: IntSet.delete cid)
1318+ . (remoteIncoming ^: IntSet.delete cid)
1321+ RemoteEndPointClosing _ _ ->
1322+ -- If the remote endpoint is in Closing state, that means that are as
1323+ -- far as we are concerned there are no incoming connections. This
1324+ -- means that a CloseConnection request at this point is invalid.
1325+ throwIO $ userError "Invalid CloseConnection request"
1326+ RemoteEndPointClosed ->
1327+ throwIO $ userError "Remote endpoint closed"
1319 writeChan ourChannel (ConnectionClosed cid)
1328 writeChan ourChannel (ConnectionClosed cid)
1320 closeIfUnused (ourEndPoint, theirEndPoint)
1329 closeIfUnused (ourEndPoint, theirEndPoint)
1322 -- Close the socket (if we don't have any outgoing connections)
1331 -- Close the socket (if we don't have any outgoing connections)
1323 closeSocket :: N.Socket -> IO Bool
1332 closeSocket :: N.Socket -> IO Bool
1324 closeSocket sock = do
1333 closeSocket sock = do
1325− -- As in modifyRemoteState we put the remote state in Closing state
1326− -- before putting it in Closed state.
1327− canClose <- modifyMVar theirState $ \st ->
1334+ modifyMVar theirState $ \st ->
1328 case st of
1335 case st of
1336+ RemoteEndPointInvalid _ ->
1337+ relyViolation (ourEndPoint, theirEndPoint) "handleIncomingMessages:closeSocket"
1329 RemoteEndPointValid vst -> do
1338 RemoteEndPointValid vst -> do
1330 -- We regard a CloseSocket message as an (optimized) way for the
1339 -- We regard a CloseSocket message as an (optimized) way for the
1331 -- remote endpoint to indicate that all its connections to us are
1340 -- remote endpoint to indicate that all its connections to us are
@@ -1338,29 +1347,18 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do
1338 then do
1347 then do
1339 -- Attempt to reply (but don't insist)
1348 -- Attempt to reply (but don't insist)
1340 tryIO $ sendOn vst' [encodeInt32 CloseSocket]
1349 tryIO $ sendOn vst' [encodeInt32 CloseSocket]
1341− resolved <- newEmptyMVar
1350+ tryCloseSocket sock
1342− return (RemoteEndPointClosing resolved vst', True)
1351+ removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1352+ return (RemoteEndPointClosed, True)
1344 return (RemoteEndPointValid vst', False)
1354 return (RemoteEndPointValid vst', False)
1345− RemoteEndPointClosing _ _ ->
1355+ RemoteEndPointClosing resolved _ -> do
1346− return (st, True)
1356+ tryCloseSocket sock
1348− error "handleIncomingConnections RELY violation"
1351− removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1357+ removeRemoteEndPoint (ourEndPoint, theirEndPoint)
1352− modifyMVar_ theirState $ \st -> do
1354− RemoteEndPointClosing resolved _ ->
1355− putMVar resolved ()
1358+ putMVar resolved ()
1356− RemoteEndPointClosed ->
1359+ return (RemoteEndPointClosed, True)
1357− return ()
1360+ RemoteEndPointClosed ->
1358− _ ->
1361+ throw $ userError "Remote endpoint closed"
1359− fail "Impossible case"
1360− return RemoteEndPointClosed
1361− tryCloseSocket sock
1365 -- Read a message and output it on the endPoint's channel By rights we
1363 -- Read a message and output it on the endPoint's channel By rights we
1366 -- should verify that the connection ID is valid, but this is unnecessary
1364 -- should verify that the connection ID is valid, but this is unnecessary
@@ -1383,14 +1381,15 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do
1383 modifyMVar_ theirState $ \st ->
1381 modifyMVar_ theirState $ \st ->
1384 case st of
1382 case st of
1385 RemoteEndPointInvalid _ ->
1383 RemoteEndPointInvalid _ ->
1386− error "handleIncomingMessages RELY violation"
1384+ relyViolation (ourEndPoint, theirEndPoint) "handleIncomingMessages:prematureExit"
1387 RemoteEndPointValid vst -> do
1385 RemoteEndPointValid vst -> do
1388 let code = EventConnectionLost
1386 let code = EventConnectionLost
1389 (remoteAddress theirEndPoint)
1387 (remoteAddress theirEndPoint)
1390 (IntSet.elems $ vst ^. remoteIncoming)
1388 (IntSet.elems $ vst ^. remoteIncoming)
1391 writeChan ourChannel . ErrorEvent $ TransportError code (show err)
1389 writeChan ourChannel . ErrorEvent $ TransportError code (show err)
1392 return RemoteEndPointClosed
1390 return RemoteEndPointClosed
1393− RemoteEndPointClosing _ _ ->
1391+ RemoteEndPointClosing resolved _ -> do
1392+ putMVar resolved ()
1394 return RemoteEndPointClosed
1393 return RemoteEndPointClosed
1395 RemoteEndPointClosed ->
1394 RemoteEndPointClosed ->
1396 return RemoteEndPointClosed
1395 return RemoteEndPointClosed
@@ -1461,3 +1460,17 @@ pendingCtrlRequestsAt ix = pendingCtrlRequests >>> DAC.intMapMaybe (fromIntegral
1461localConnectionTo :: EndPointAddress
1460localConnectionTo :: EndPointAddress
1462 -> Accessor ValidLocalEndPointState (Maybe RemoteEndPoint)
1461 -> Accessor ValidLocalEndPointState (Maybe RemoteEndPoint)
1463localConnectionTo addr = localConnections >>> DAC.mapMaybe addr
1462localConnectionTo addr = localConnections >>> DAC.mapMaybe addr
1464+-------------------------------------------------------------------------------
1466+-------------------------------------------------------------------------------
1468+relyViolation :: EndPointPair -> String -> IO a
1469+relyViolation (ourEndPoint, theirEndPoint) str = do
1470+ elog (ourEndPoint, theirEndPoint) (str ++ " RELY violation")
1471+ fail (str ++ " RELY violation")
1473+elog :: EndPointPair -> String -> IO ()
1474+elog (ourEndPoint, theirEndPoint) msg = do
1476+ putStrLn $ show (localAddress ourEndPoint) ++ "/" ++ show (remoteAddress theirEndPoint) ++ "/" ++ show tid ++ ": " ++ msg