make sure send sockets are bound to the correct local IP

src/Hash2Pub/DHTProtocol.hs

@@ -65,10 +65,13 @@ import           System.Timeout
 
 import           Hash2Pub.ASN1Coding
 import           Hash2Pub.FediChordTypes        (CacheEntry (..),
-                                                 CacheEntry (..), HasKeyID (..),
+                                                 CacheEntry (..),
+                                                 FediChordConf (..),
+                                                 HasKeyID (..),
                                                  LocalNodeState (..),
                                                  LocalNodeStateSTM, NodeCache,
                                                  NodeID, NodeState (..),
+                                                 RealNode (..),
                                                  RemoteNodeState (..),
                                                  RingEntry (..), RingMap (..),
                                                  addRMapEntry, addRMapEntryWith,
@@ -445,10 +448,12 @@ respondJoin nsSTM msgSet = do
 requestJoin :: NodeState a => a             -- ^ currently responsible node to be contacted
             -> LocalNodeStateSTM               -- ^ joining NodeState
             -> IO (Either String LocalNodeStateSTM)    -- ^ node after join with all its new information
-requestJoin toJoinOn ownStateSTM =
-    bracket (mkSendSocket (getDomain toJoinOn) (getDhtPort toJoinOn)) close (\sock -> do
+requestJoin toJoinOn ownStateSTM = do
+    ownState <- readTVarIO ownStateSTM
+    prn <- readTVarIO $ parentRealNode ownState
+    srcAddr <- confIP . nodeConfig <$> readTVarIO (parentRealNode ownState)
+    bracket (mkSendSocket srcAddr (getDomain toJoinOn) (getDhtPort toJoinOn)) close (\sock -> do
         -- extract own state for getting request information
-        ownState <- readTVarIO ownStateSTM
         responses <- sendRequestTo 5000 3 (\rid -> Request rid (toRemoteNodeState ownState) 1 True Join (Just JoinRequestPayload)) sock
         (cacheInsertQ, joinedState) <- atomically $ do
             stateSnap <- readTVar ownStateSTM
@@ -538,8 +543,10 @@ sendQueryIdMessages :: (Integral i)
 sendQueryIdMessages targetID ns lParam targets = do
 
           -- create connected sockets to all query targets and use them for request handling
+
+          srcAddr <- confIP . nodeConfig <$> readTVarIO (parentRealNode ns)
           -- ToDo: make attempts and timeout configurable
-          queryThreads <- mapM (\resultNode -> async $ bracket (mkSendSocket (getDomain resultNode) (getDhtPort resultNode)) close (
+          queryThreads <- mapM (\resultNode -> async $ bracket (mkSendSocket srcAddr (getDomain resultNode) (getDhtPort resultNode)) close (
               sendRequestTo 5000 3 (lookupMessage targetID ns Nothing)
                                                                                                                                    )) targets
           -- ToDo: process results immediately instead of waiting for the last one to finish, see https://stackoverflow.com/a/38815224/9198613
@@ -581,7 +588,8 @@ requestStabilise :: LocalNodeState      -- ^ sending node
                  -> RemoteNodeState     -- ^ neighbour node to send to
                  -> IO (Either String ([RemoteNodeState], [RemoteNodeState]))   -- ^ (predecessors, successors) of responding node
 requestStabilise ns neighbour = do
-    responses <- bracket (mkSendSocket (getDomain neighbour) (getDhtPort neighbour)) close (fmap Right . sendRequestTo 5000 3 (\rid ->
+    srcAddr <- confIP . nodeConfig <$> readTVarIO (parentRealNode ns)
+    responses <- bracket (mkSendSocket srcAddr (getDomain neighbour) (getDhtPort neighbour)) close (fmap Right . sendRequestTo 5000 3 (\rid ->
         Request {
             requestID = rid
           , sender = toRemoteNodeState ns
@@ -615,7 +623,8 @@ requestPing :: LocalNodeState      -- ^ sending node
                  -> RemoteNodeState     -- ^ node to be PINGed
                  -> IO (Either String [RemoteNodeState])   -- ^ all active vServers of the pinged node
 requestPing ns target = do
-    responses <- bracket (mkSendSocket (getDomain target) (getDhtPort target)) close
+    srcAddr <- confIP . nodeConfig <$> readTVarIO (parentRealNode ns)
+    responses <- bracket (mkSendSocket srcAddr (getDomain target) (getDhtPort target)) close
         (\sock -> do
             resp <- sendRequestTo 5000 3 (\rid ->
                 Request {
@@ -767,12 +776,17 @@ mkServerSocket ip port = do
 
 -- | create a UDP datagram socket, connected to a destination.
 -- The socket gets an arbitrary free local port assigned.
-mkSendSocket :: String  -- ^ destination hostname or IP
+mkSendSocket :: HostAddress6    -- ^ source address
+             -> String  -- ^ destination hostname or IP
              -> PortNumber  -- ^ destination port
              -> IO Socket   -- ^ a socket with an arbitrary source port
-mkSendSocket dest destPort = do
+mkSendSocket srcIp dest destPort = do
+    srcAddr <- addrAddress <$> resolve (Just $ show . fromHostAddress6 $ srcIp) Nothing
     destAddr <- addrAddress <$> resolve (Just dest) (Just destPort)
     sendSock <- socket AF_INET6 Datagram defaultProtocol
     setSocketOption sendSock IPv6Only 1
+    -- bind to the configured local IP to make sure that outgoing packets are sent from
+    -- this source address
+    bind sendSock srcAddr
     connect sendSock destAddr
     pure sendSock

src/Hash2Pub/FediChord.hs

@@ -208,7 +208,8 @@ tryBootstrapJoining nsSTM = do
 bootstrapQueryId :: LocalNodeStateSTM -> (String, PortNumber) -> NodeID -> IO (Either String RemoteNodeState)
 bootstrapQueryId nsSTM (bootstrapHost, bootstrapPort) targetID = do
     ns <- readTVarIO nsSTM
-    bootstrapResponse <- bracket (mkSendSocket bootstrapHost bootstrapPort) close (
+    srcAddr <- confIP . nodeConfig <$> readTVarIO (parentRealNode ns)
+    bootstrapResponse <- bracket (mkSendSocket srcAddr bootstrapHost bootstrapPort) close (
         -- Initialise an empty cache only with the responses from a bootstrapping node
         fmap Right . sendRequestTo 5000 3 (lookupMessage targetID ns Nothing)
                                                                                   )