Configurable bind-addresses for xmpp.

2 files changed, 21 insertions, 13 deletions

diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index 198012de..4aa24eb5 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -139,8 +139,10 @@ nameForClient state k = do
             "."     -> textHostName
             profile -> return profile
 
-presenceHooks :: PresenceState -> Int -> Maybe PortNumber -> XMPPServerParameters
-presenceHooks state verbosity mport = XMPPServerParameters
+presenceHooks :: PresenceState -> Int -> Maybe SockAddr -- ^ client-to-server bind address
+                                      -> Maybe SockAddr -- ^ server-to-server bind address
+                                      -> XMPPServerParameters
+presenceHooks state verbosity mclient mpeer = XMPPServerParameters
     { xmppChooseResourceName        = chooseResourceName state
     , xmppTellClientHisName         = tellClientHisName state
     , xmppTellMyNameToClient        = nameForClient state
@@ -163,7 +165,8 @@ presenceHooks state verbosity mport = XMPPServerParameters
     , xmppClientInformSubscription  = clientInformSubscription state
     , xmppPeerInformSubscription    = peerInformSubscription state
     , xmppVerbosity                 = return verbosity
-    , xmppClientPort                = fromMaybe 5222 mport
+    , xmppClientBind                = mclient
+    , xmppPeerBind                  = mpeer
     }
 
 
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index bc5e88da..bcd75ee2 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -39,6 +39,9 @@ import EventUtil
 import ControlMaybe
 import LockedChan
 import PeerResolve
+import qualified Connection
+import Util
+import Network.Address (getBindAddress, sockAddrPort)
 import Blaze.ByteString.Builder (Builder)
 
 import Debug.Trace
@@ -88,11 +91,9 @@ import Data.Void (Void)
 import System.Endian (toBE32)
 import Control.Applicative
 import System.IO
-import qualified Connection
-import Util
 
-peerport :: PortNumber
-peerport = 5269
+-- peerport :: PortNumber
+-- peerport = 5269
 -- clientport :: PortNumber
 -- clientport = 5222
 
@@ -217,7 +218,8 @@ data XMPPServerParameters =
     , -- | Called when a remote peer informs us of our subscription status.
       xmppPeerInformSubscription :: IO () -> ConnectionKey -> Stanza -> IO ()
     , xmppVerbosity          :: IO Int
-    , xmppClientPort :: PortNumber -- 5222
+    , xmppClientBind         :: Maybe SockAddr
+    , xmppPeerBind           :: Maybe SockAddr
     }
 
 
@@ -1387,14 +1389,15 @@ data PeerState
     | PeerConnected (TChan Stanza)
 -}
 
-peerKey :: SocketLike sock => sock -> IO (ConnectionKey,SockAddr)
-peerKey sock = do
+peerKey :: SocketLike sock => Maybe SockAddr -> sock -> IO (ConnectionKey,SockAddr)
+peerKey outgoingPeerPort sock = do
     addr <- getSocketName sock
     peer <-
       sIsConnected sock >>= \c ->
         if c then getPeerName sock -- addr is normally socketName
              else return addr      -- Weird hack: addr is would-be peer name
     laddr <- getSocketName sock
+    let peerport = fromMaybe 5269 $ outgoingPeerPort >>= sockAddrPort
     return $ (PeerKey (peer `withPort` fromIntegral peerport),laddr)
 
 clientKey :: SocketLike sock => sock -> IO (ConnectionKey,SockAddr)
@@ -1833,7 +1836,7 @@ xmppServer xmpp = do
         let (r,gen') = System.Random.next gen
         return $ r `mod` 2000 -- maximum 2 seconds of fuzz
     liftIO . wlog $ "pingfuzz = " ++ show pingfuzz
-    let peer_params = (connectionDefaults peerKey)
+    let peer_params = (connectionDefaults $ peerKey $ xmppPeerBind xmpp)
                           { pingInterval = 15000 + pingfuzz
                           , timeout = 2000
                           , duplex = False }
@@ -1846,9 +1849,11 @@ xmppServer xmpp = do
             myThreadId >>= flip labelThread ("XMPP.monitor")
             monitor sv peer_params xmpp
         hPutStrLn stderr $ "Starting peer listen"
-        control sv (Listen peerport peer_params)
+        peer_bind <- maybe (getBindAddress "5269" True) return $ xmppPeerBind xmpp
+        control sv (Listen peer_bind peer_params)
         hPutStrLn stderr $ "Starting client listen"
-        control sv (Listen (xmppClientPort xmpp) client_params)
+        client_bind <- maybe (getBindAddress "5222" True) return $ xmppClientBind xmpp
+        control sv (Listen client_bind client_params)
     return XMPPServer { _xmpp_sv = sv, _xmpp_peer_params = peer_params }
 
 #if MIN_VERSION_stm(2,4,0)