9 files changed, 317 insertions, 227 deletions

diff --git a/Connection.hs b/Connection.hs
index a7e5d4cc..9a4077f5 100644
--- a/Connection.hs
+++ b/Connection.hs
@@ -5,8 +5,11 @@ module Connection where
 import Control.Applicative
 import Control.Arrow
 import Control.Concurrent.STM
+import Data.Bits
+import Data.Word
 import qualified Data.Map as Map
          ;import Data.Map (Map)
+import Network.Socket (SockAddr(..))
 
 import PingMachine
 
@@ -34,6 +37,43 @@ data Connection status = Connection
     }
  deriving Functor
 
+-- | A 'PeerAddress' identifies an active session.  For inactive sessions, multiple
+-- values may be feasible.
+
+-- We use a 'SockAddr' as it is convenient for TCP and UDP connections.  But if
+-- that is not your use case, see 'uniqueAsKey'.
+newtype PeerAddress = PeerAddress { peerAddress :: SockAddr }
+    deriving (Eq,Ord,Show)
+
+-- | A 24-byte word.
+data Uniq24 = Uniq24 !Word64 !Word64 !Word64
+ deriving (Eq,Ord,Show)
+
+-- | Coerce a 'Uniq24' to a useable 'PeerAddress'.  Note that this stores the
+-- special value 0 into the port number of the underlying 'SockAddr' and thus
+-- should be compatible for mixing together with TCP/UDP peers.
+uniqueAsKey :: Uniq24 -> PeerAddress
+uniqueAsKey (Uniq24 x y z) = PeerAddress $ SockAddrInet6 (fromIntegral 0) a bcde f
+ where
+    a = fromIntegral (x `shiftR` 32)
+    b = fromIntegral x
+    c = fromIntegral (y `shiftR` 32)
+    d = fromIntegral y
+    e = fromIntegral (z `shiftR` 32)
+    f = fromIntegral z
+    bcde = (b,c,d,e)
+
+-- | Inverse of 'uniqueAsKey'
+keyAsUnique :: PeerAddress -> Maybe Uniq24
+keyAsUnique (PeerAddress (SockAddrInet6 0 a bcde f)) = Just $ Uniq24 x y z
+ where
+    (b,c,d,e) = bcde
+    x = (fromIntegral a `shiftL` 32) .|. fromIntegral b
+    y = (fromIntegral c `shiftL` 32) .|. fromIntegral d
+    z = (fromIntegral e `shiftL` 32) .|. fromIntegral f
+keyAsUniq _ = Nothing
+
+
 -- | This is an interface to make or query status information about connections
 -- of a specific kind.
 --
@@ -58,6 +98,12 @@ data Manager status k = Manager
     , showProgress :: status -> String
       -- | Show a connection key as a string.
     , showKey      :: k -> String
+      -- | Obtain an address from a human-friendly name.  For TCP/UDP
+      -- connections, this might be a forward-resolving DNS query.
+    , resolvePeer :: k -> IO [PeerAddress]
+      -- | This is the reverse of 'resolvePeer'.  For TCP/UDP connections, this
+      -- might be a reverse-resolve DNS query.
+    , reverseAddress :: PeerAddress -> IO [k]
     }
 
 -- | Present status information (visible in a UI) for a connection.
diff --git a/Connection/Tcp.hs b/Connection/Tcp.hs
index c6f3a8ce..35083198 100644
--- a/Connection/Tcp.hs
+++ b/Connection/Tcp.hs
@@ -52,6 +52,7 @@ import Control.Monad.Fix
 -- import Control.Monad.STM
 -- import Control.Monad.Trans.Resource
 import Control.Monad.IO.Class (MonadIO (liftIO))
+import Data.Maybe
 import System.IO.Error (isDoesNotExistError)
 import System.IO
     ( IOMode(..)
@@ -71,12 +72,15 @@ import Data.Time.Clock (getCurrentTime,diffUTCTime)
 -- import SockAddr ()
 -- import System.Locale (defaultTimeLocale)
 
+import qualified Data.Text as Text
+         ;import Data.Text (Text)
+import DNSCache
 import InterruptibleDelay
 import PingMachine
 import Network.StreamServer
 import Network.SocketLike hiding (sClose)
 import qualified Connection as G
-         ;import Connection (Manager (..), Policy(..))
+         ;import Connection (Manager (..), PeerAddress (..), Policy (..))
 import DPut
 
 
@@ -763,15 +767,22 @@ debugNoise str = return ()
 
 data TCPStatus = Resolving | AwaitingRead | AwaitingWrite
 
-tcpManager :: ( Show k, Ord k, Ord conkey ) =>
-              (conkey -> (SockAddr, ConnectionParameters conkey u, Miliseconds))
-              -> (String -> Maybe k)
-              -> (k -> IO (Maybe conkey))
-              -> Server conkey u releaseKey x
-              -> IO (Manager TCPStatus k)
-tcpManager grokKey s2k resolvKey sv = do
+-- SockAddr -> (SockAddr, ConnectionParameters SockAddr ConnectionData, Miliseconds)
+
+
+tcpManager :: (PeerAddress -> (SockAddr, ConnectionParameters PeerAddress u, Miliseconds))
+              -- -> (String -> Maybe Text)
+              -- -> (Text -> IO (Maybe PeerAddress))
+              -> Server PeerAddress u releaseKey x
+              -> IO (Manager TCPStatus Text)
+tcpManager grokKey sv = do
     rmap <- atomically $ newTVar Map.empty -- Map k (Maybe conkey)
     nullping <- forkPingMachine "tcpManager" 0 0
+    (rslv,rev) <- do
+        dns <- newDNSCache
+        let rslv k = map PeerAddress <$> forwardResolve dns k
+            rev (PeerAddress addr) = reverseResolve dns addr
+        return (rslv,rev)
     return Manager {
       setPolicy = \k -> \case
         TryingToConnect -> join $ atomically $ do
@@ -782,7 +793,7 @@ tcpManager grokKey s2k resolvKey sv = do
                     modifyTVar' rmap $ Map.insert k Nothing
                     return $ void $ forkIO $ do
                     myThreadId >>= flip labelThread ("resolve."++show k)
-                    mconkey <- resolvKey k
+                    mconkey <- listToMaybe <$> rslv k
                     case mconkey of
                         Nothing     -> atomically $ modifyTVar' rmap $ Map.delete k
                         Just conkey -> do
@@ -795,12 +806,14 @@ tcpManager grokKey s2k resolvKey sv = do
         ck <- Map.lookup k <$> readTVar rmap
         return $ exportConnection c (join ck)
     , connections = Map.keys <$> readTVar rmap
-    , stringToKey = s2k
+    , stringToKey = Just . Text.pack
     , showProgress = \case
         Resolving     -> "resolving"
         AwaitingRead  -> "awaiting inbound"
         AwaitingWrite -> "awaiting outbound"
     , showKey = show
+    , resolvePeer    = rslv
+    , reverseAddress = rev
     }
 
 exportConnection :: Ord conkey => Map conkey (ConnectionRecord u) -> Maybe conkey -> G.Connection TCPStatus
diff --git a/Presence/ConnectionKey.hs b/Presence/ConnectionKey.hs
index f0180455..ad4eeab7 100644
--- a/Presence/ConnectionKey.hs
+++ b/Presence/ConnectionKey.hs
@@ -3,9 +3,6 @@ module ConnectionKey where
 import Network.Socket ( SockAddr(..) )
 import SockAddr ()
 
-newtype PeerAddress = PeerAddress SockAddr
-    deriving (Eq,Ord,Show)
-
 newtype ClientAddress = ClientAddress SockAddr
     deriving (Eq,Ord,Show)
 
diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index fad87aeb..98d701e9 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -39,17 +39,18 @@ import Control.Applicative
 import Crypto.PubKey.Curve25519 (SecretKey,toPublic)
 
 import ControlMaybe
+import DNSCache (parseAddress, strip_brackets, withPort)
 import LockedChan (LockedChan)
 import Text.Read (readMaybe)
 import TraversableT
 import UTmp (ProcessID,users)
 import LocalPeerCred
 import XMPPServer
-import PeerResolve
 import ConsoleWriter
 import ClientState
 import Util
 import qualified Connection
+         ;import Connection (PeerAddress (..), resolvePeer, reverseAddress)
 import Network.Tox.NodeId (key2id,parseNoSpamId,nospam64,NoSpamId(..),ToxProgress,ToxContact(..))
 import Crypto.Tox (decodeSecret)
 import DPut
@@ -88,13 +89,16 @@ data ToxManager k = ToxManager
     , resolveToxPeer         :: Text -> Text -> IO (Maybe PeerAddress)
     }
 
-data PresenceState = forall status. PresenceState
+type ClientProfile = Text
+
+data PresenceState status = PresenceState
     { clients         :: TVar (Map ClientAddress ClientState)
     , clientsByUser   :: TVar (Map Text LocalPresence)
     , clientsByProfile :: TVar (Map Text LocalPresence)
     , remotesByPeer   :: TVar (Map PeerAddress
                                    (Map UserName RemotePresence))
-    , server          :: TMVar (XMPPServer, Connection.Manager status Text)
+    , server          :: XMPPServer
+    , manager         :: ClientProfile -> Connection.Manager status Text
     , ckeyToChan       :: TVar (Map ClientAddress Conn)
     , pkeyToChan       :: TVar (Map PeerAddress Conn)
     , consoleWriter   :: Maybe ConsoleWriter
@@ -103,10 +107,11 @@ data PresenceState = forall status. PresenceState
 
 
 newPresenceState :: Maybe ConsoleWriter
-                 -> Maybe (PresenceState -> ToxManager ClientAddress)
-                 -> TMVar (XMPPServer, Connection.Manager status Text)
-                 -> IO PresenceState
-newPresenceState cw toxman xmpp = atomically $ do
+                 -> Maybe (PresenceState status -> ToxManager ClientAddress)
+                 -> XMPPServer
+                 -> (ClientProfile -> Connection.Manager status Text)
+                 -> IO (PresenceState status)
+newPresenceState cw toxman sv man = atomically $ do
         clients          <- newTVar Map.empty
         clientsByUser    <- newTVar Map.empty
         clientsByProfile <- newTVar Map.empty
@@ -120,14 +125,15 @@ newPresenceState cw toxman xmpp = atomically $ do
                     , remotesByPeer    = remotesByPeer
                     , ckeyToChan       = ckeyToChan
                     , pkeyToChan       = pkeyToChan
-                    , server           = xmpp
+                    , server           = sv
+                    , manager          = man
                     , consoleWriter    = cw
                     , toxManager       = Nothing
                     }
         return $ st { toxManager = fmap ($ st) toxman }
 
 
-nameForClient :: PresenceState -> ClientAddress -> IO Text
+nameForClient :: PresenceState stat -> ClientAddress -> IO Text
 nameForClient state k = do
     mc <- atomically $ do
         cmap <- readTVar (clients state)
@@ -138,7 +144,7 @@ nameForClient state k = do
             "."     -> textHostName
             profile -> return profile
 
-presenceHooks :: PresenceState -> Int -> Maybe SockAddr -- ^ client-to-server bind address
+presenceHooks :: PresenceState stat -> Int -> Maybe SockAddr -- ^ client-to-server bind address
                                       -> Maybe SockAddr -- ^ server-to-server bind address
                                       -> XMPPServerParameters
 presenceHooks state verbosity mclient mpeer = XMPPServerParameters
@@ -204,7 +210,7 @@ pcIsEmpty pc = Map.null (networkClients pc)
 
 
 
-getConsolePids :: PresenceState -> IO [(Text,ProcessID)]
+getConsolePids :: PresenceState stat -> IO [(Text,ProcessID)]
 getConsolePids state = do
     us <- UTmp.users
     return $ map (\(_,tty,pid)->(lazyByteStringToText tty,pid)) us
@@ -218,7 +224,7 @@ identifyTTY' ttypids uid inode = ttypid
        ttypid = fmap textify $ identifyTTY ttypids' uid inode
        textify (tty,pid) = (fmap lazyByteStringToText tty, pid)
 
-chooseResourceName :: PresenceState
+chooseResourceName :: PresenceState stat
                     -> ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO Text
 chooseResourceName state k (Remote addr) clientsNameForMe desired = do
     muid <- getLocalPeerCred' addr
@@ -267,7 +273,7 @@ chooseResourceName state k (Remote addr) clientsNameForMe desired = do
        buds <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client)
        forM_ buds $ \bud -> do
             let (_,h,_) = splitJID bud
-            forkIO $ void $ resolvePeer h
+            forkIO $ void $ resolvePeer (manager state $ clientProfile client) h
 
     atomically $ do
         modifyTVar' (clients state) $ Map.insert k client
@@ -304,14 +310,14 @@ chooseResourceName state k (Remote addr) clientsNameForMe desired = do
 -- Perform action with 'ClientState' associated with the given 'ClientAddress'.
 -- If there is no associated 'ClientState', then perform the supplied fallback
 -- action.
-forClient :: PresenceState -> ClientAddress -> IO b -> (ClientState -> IO b) -> IO b
+forClient :: PresenceState stat -> ClientAddress -> IO b -> (ClientState -> IO b) -> IO b
 forClient state k fallback f = do
     mclient <- atomically $ do
         cs <- readTVar (clients state)
         return $ Map.lookup k cs
     maybe fallback f mclient
 
-tellClientHisName :: PresenceState -> ClientAddress -> IO Text
+tellClientHisName :: PresenceState stat -> ClientAddress -> IO Text
 tellClientHisName state k = forClient state k fallback go
  where
     fallback  = localJID "nobody" "." "fallback"
@@ -320,22 +326,22 @@ tellClientHisName state k = forClient state k fallback go
 toMapUnit :: Ord k => [k] -> Map k ()
 toMapUnit xs = Map.fromList $ map (,()) xs
 
-resolveAllPeers :: [Text] -> IO (Map PeerAddress ())
-resolveAllPeers hosts = fmap (toMapUnit . concat) $ Prelude.mapM (fmap (take 1) . resolvePeer) hosts
+resolveAllPeers :: Connection.Manager stat Text -> [Text] -> IO (Map PeerAddress ())
+resolveAllPeers man hosts = fmap (toMapUnit . concat) $ Prelude.mapM (fmap (take 1) . resolvePeer man) hosts
 
 
 -- Read a roster file and start trying to connect to all relevent peers.
 rosterGetStuff
   :: (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString])
-     -> PresenceState -> ClientAddress -> IO [Text]
+     -> PresenceState stat -> ClientAddress -> IO [Text]
 rosterGetStuff what state k = forClient state k (return [])
     $ \client -> do
     jids0 <- configText what (clientUser client) (clientProfile client)
     let jids = map splitJID jids0
     -- Using case to bring 'status' type variable to Connection.Manager into scope.
     case state of
-      PresenceState { server = svVar } -> do
-        (sv,conns) <- atomically $ takeTMVar svVar
+      PresenceState { server = sv } -> do
+        let conns = manager state $ clientProfile client
         -- Grok peers to associate with from the roster:
         let isTox = do (me  , ".tox") <- Just $ Text.splitAt 43 (clientProfile client)
                        return me
@@ -353,23 +359,22 @@ rosterGetStuff what state k = forClient state k (return [])
                     meid <- readMaybe $ Text.unpack $ Text.take 43 (clientProfile client)
                     themid <- readMaybe $ Text.unpack them
                     return $ Connection.setPolicy (toxConnections toxman)
-                                                      (ToxContact meid themid)
+                                                  (ToxContact meid themid)
             policySetter Connection.TryingToConnect
-        atomically $ putTMVar svVar (sv,conns)
         return $ fromMaybe jids0 $ do isTox
                                       Just $ map noToxUsers jids
 
-rosterGetBuddies :: PresenceState -> ClientAddress -> IO [Text]
+rosterGetBuddies :: PresenceState stat -> ClientAddress -> IO [Text]
 rosterGetBuddies state k = rosterGetStuff ConfigFiles.getBuddies state k
 
-rosterGetSolicited :: PresenceState -> ClientAddress -> IO [Text]
+rosterGetSolicited :: PresenceState stat -> ClientAddress -> IO [Text]
 rosterGetSolicited = rosterGetStuff ConfigFiles.getSolicited
 
 -- XXX: Should we be connecting to these peers?
-rosterGetOthers :: PresenceState -> ClientAddress -> IO [Text]
+rosterGetOthers :: PresenceState stat -> ClientAddress -> IO [Text]
 rosterGetOthers = rosterGetStuff ConfigFiles.getOthers
 
-rosterGetSubscribers :: PresenceState -> ClientAddress -> IO [Text]
+rosterGetSubscribers :: PresenceState stat -> ClientAddress -> IO [Text]
 rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers
 
 data Conn = Conn { connChan :: TChan Stanza
@@ -404,7 +409,7 @@ getSolicited' = configText ConfigFiles.getSolicited
 --
 --   * Text - Hostname as it appears in roster.
 --
-getBuddiesAndSolicited :: PresenceState
+getBuddiesAndSolicited :: PresenceState stat
                          -> Text              -- ^ Config profile: "." or tox host.
                          -> (Text -> IO Bool) -- ^ Return True if you want this hostname.
                          -> IO [(Bool, Maybe UserName, Text, Text)]
@@ -425,7 +430,7 @@ getBuddiesAndSolicited state profile pred
                     then return [(isbud,u,user,h)]
                     else return []
 
-sendProbesAndSolicitations :: PresenceState -> PeerAddress -> Local SockAddr -> TChan Stanza -> IO ()
+sendProbesAndSolicitations :: PresenceState stat -> PeerAddress -> Local SockAddr -> TChan Stanza -> IO ()
 sendProbesAndSolicitations state k (Local laddr) chan = do
     prof <- atomically $ do
         pktc <- readTVar (pkeyToChan state)
@@ -434,7 +439,7 @@ sendProbesAndSolicitations state k (Local laddr) chan = do
     xs <- getBuddiesAndSolicited state prof $ \case
         h | ".tox" `Text.isSuffixOf` h -> return False -- Tox probes/solicitations are handled in ToxToXMPP module.
         h -> do
-            addrs <- nub <$> resolvePeer h
+            addrs <- nub <$> resolvePeer (manager state $ prof) h
             return $ k `elem` addrs -- Roster item resolves to /k/ peer.
     forM_ xs $ \(isbud,u,user,h) -> do
         let make = if isbud then presenceProbe
@@ -452,7 +457,7 @@ sendProbesAndSolicitations state k (Local laddr) chan = do
     -- reverse xs `seq` return ()
 
 
-newConn :: PresenceState -> SockAddr -> ConnectionData -> TChan Stanza -> IO ()
+newConn :: PresenceState stat -> SockAddr -> ConnectionData -> TChan Stanza -> IO ()
 newConn state saddr cdta outchan =
     case classifyConnection saddr cdta of
         Left (pkey,laddr) -> do
@@ -473,7 +478,7 @@ delclient k mlp = do
     guard $ not (Map.null nc)
     return $ lp { networkClients = nc }
 
-eofConn :: PresenceState -> SockAddr -> ConnectionData -> IO ()
+eofConn :: PresenceState stat -> SockAddr -> ConnectionData -> IO ()
 eofConn state saddr cdta = do
     case classifyConnection saddr cdta of
         Left (k,_) -> do
@@ -545,9 +550,9 @@ parseRemoteAddress s = fmap Remote <$> parseAddress s
 -- domain name as it appears in the roster.  It prefers host names that occur
 -- in the given list of JIDs, but will fall back to any reverse-resolved name
 -- and if it was unable to reverse the address, it will yield an ip address.
-peerKeyToResolvedName :: [Text] -> PeerAddress -> IO Text
-peerKeyToResolvedName buds pk = do
-    ns <- peerKeyToResolvedNames pk
+peerKeyToResolvedName :: Connection.Manager s Text -> [Text] -> PeerAddress -> IO Text
+peerKeyToResolvedName man buds pk = do
+    ns <- reverseAddress man pk
     let hs = map (\jid -> let (_,h,_)=splitJID jid in h) buds
         ns' = sortBy (comparing $ not . flip elem hs) ns
     return $ fromMaybe (peerKeyToText pk) (listToMaybe ns')
@@ -559,22 +564,22 @@ peerKeyToResolvedName buds pk = do
 -- host part refers to this local host (i.e. it equals the given SockAddr).
 -- If there are multiple results, it will prefer one which is a member of the
 -- given list in the last argument.
-rewriteJIDForClient :: Local SockAddr -> Text -> [Text] -> IO (Bool,(Maybe Text,Text,Maybe Text))
-rewriteJIDForClient (Local laddr) jid buds = do
+rewriteJIDForClient :: Connection.Manager s Text -> Local SockAddr -> Text -> [Text] -> IO (Bool,(Maybe Text,Text,Maybe Text))
+rewriteJIDForClient man (Local laddr) jid buds = do
     let (n,h,r) = splitJID jid
     -- dput XJabber $ "rewriteJIDForClient parsing " ++ show h
     maddr <- parseAddress (strip_brackets h)
     fromMaybe (return (False,(n,ip6literal h,r))) $ maddr <&> \saddr -> do
     let mine =  sameAddress laddr saddr
     h' <- if mine then textHostName
-                  else peerKeyToResolvedName buds (addrToPeerKey $ Remote saddr)
+                  else peerKeyToResolvedName man buds (addrToPeerKey $ Remote saddr)
     return (mine,(n,h',r))
 
 -- Given a local address and an IP-address JID, we return True if the JID is
 -- local, False otherwise.  Additionally, a list of equivalent hostname JIDS
 -- are returned.
-multiplyJIDForClient :: ClientAddress -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)])
-multiplyJIDForClient k jid = do
+multiplyJIDForClient :: Connection.Manager s Text -> ClientAddress -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)])
+multiplyJIDForClient man k jid = do
     let (n,h,r) = splitJID jid
     -- dput XJabber $ "multiplyJIDForClient parsing " ++ show h
     maddr <- parseAddress (strip_brackets h)
@@ -582,7 +587,7 @@ multiplyJIDForClient k jid = do
     let Local laddr = addrFromClientKey k
         mine        = sameAddress laddr saddr
     names <- if mine then fmap (:[]) textHostName
-                     else peerKeyToResolvedNames (addrToPeerKey $ Remote saddr)
+                     else reverseAddress man (addrToPeerKey $ Remote saddr)
     return (mine,map (\h' -> (n,h',r)) names)
 
 
@@ -600,16 +605,16 @@ guardPortStrippedAddress h (Local laddr) = do
 -- with a PeerAddress with the address part of that JID in
 -- binary form.  If no suitable address could be resolved
 -- for the given name, Nothing is returned.
-rewriteJIDForPeer :: Text -> IO (Maybe (Text,PeerAddress))
-rewriteJIDForPeer jid = do
+rewriteJIDForPeer :: Connection.Manager s Text -> Text -> IO (Maybe (Text,PeerAddress))
+rewriteJIDForPeer man jid = do
     let (n,h,r) = splitJID jid
-    maddr <- fmap listToMaybe $ resolvePeer h
+    maddr <- fmap listToMaybe $ resolvePeer man h
     return $ flip fmap maddr $ \addr ->
         let h' = peerKeyToText addr
             to' = unsplitJID (n,h',r)
         in (to',addr)
 
-deliverToConsole :: PresenceState -> IO () -> Stanza -> IO ()
+deliverToConsole :: PresenceState stat -> IO () -> Stanza -> IO ()
 deliverToConsole PresenceState{ consoleWriter = Just cw } fail msg = do
     did1 <- writeActiveTTY cw msg
     did2 <- writeAllPty cw msg
@@ -617,7 +622,7 @@ deliverToConsole PresenceState{ consoleWriter = Just cw } fail msg = do
 deliverToConsole _ fail _ = fail
 
 -- | deliver <message/> or error stanza
-deliverMessage :: PresenceState
+deliverMessage :: PresenceState stat
                 -> IO ()
                 -> StanzaWrap (LockedChan Event)
                 -> IO ()
@@ -630,7 +635,8 @@ deliverMessage state fail msg =
             return $ do
               dput XJabber $ "deliverMessage: to="++show (stanzaTo msg,fmap clientProfile mclient)
               fromMaybe -- Resolve XMPP peer.
-                          (fmap join $ mapM rewriteJIDForPeer (stanzaTo msg))
+                          (fmap join $ mapM (uncurry $ rewriteJIDForPeer . manager state)
+                                     $ (,) <$> (clientProfile <$> mclient) <*> stanzaTo msg)
                 $ do
                      client <- mclient
                      to <- stanzaTo msg
@@ -679,7 +685,7 @@ deliverMessage state fail msg =
         (mine,(n,h,r)) <- case (ctyp,cprof) of
             (Tox,prof) -> let (n,h,r) = splitJID to
                           in return ( h==prof, (n,h,r) )
-            _          -> rewriteJIDForClient laddr to []
+            _          -> rewriteJIDForClient (manager state cprof) laddr to []
         if not mine then do dput XJabber $ "Address mis-match " ++ show (laddr,to)
                             fail
                     else do
@@ -701,7 +707,7 @@ deliverMessage state fail msg =
               Tox  -> return $ stanzaFrom msg
               XMPP -> do
                 forM (stanzaFrom msg) $ \from -> do
-                (_,trip) <- rewriteJIDForClient laddr from buds
+                (_,trip) <- rewriteJIDForClient (manager state cprof) laddr from buds
                 return $ unsplitJID trip
             to' <- case ctyp of
                 XMPP -> return $ stanzaTo msg
@@ -715,7 +721,7 @@ deliverMessage state fail msg =
                 buds <- maybe (return [])
                               (\n -> configText ConfigFiles.getBuddies n ".")
                               n
-                (_,trip) <- rewriteJIDForClient laddr from buds
+                (_,trip) <- rewriteJIDForClient (manager state cprof) laddr from buds
                 return . Just $ unsplitJID trip
             let msg' = msg { stanzaTo=Just to'
                            , stanzaFrom=from' }
@@ -735,7 +741,7 @@ deliverMessage state fail msg =
                                       chan
 
 
-setClientFlag :: PresenceState -> ClientAddress -> Int8 -> IO ()
+setClientFlag :: PresenceState stat -> ClientAddress -> Int8 -> IO ()
 setClientFlag state k flag =
     atomically $ do
         cmap <- readTVar (clients state)
@@ -746,16 +752,16 @@ setClientFlag0 :: ClientState -> Int8 -> STM ()
 setClientFlag0 client flag =
     modifyTVar' (clientFlags client) (\flgs -> flgs .|. flag)
 
-informSentRoster :: PresenceState -> ClientAddress -> IO ()
+informSentRoster :: PresenceState stat -> ClientAddress -> IO ()
 informSentRoster state k = do
     setClientFlag state k cf_interested
 
 
-subscribedPeers :: Text -> Text -> IO [PeerAddress]
-subscribedPeers user profile = do
+subscribedPeers :: Connection.Manager s Text -> Text -> Text -> IO [PeerAddress]
+subscribedPeers man user profile = do
     jids <- configText ConfigFiles.getSubscribers user profile
     let hosts = map ((\(_,h,_)->h) . splitJID) jids
-    fmap Map.keys $ resolveAllPeers hosts
+    fmap Map.keys $ resolveAllPeers man hosts
 
 -- | this JID is suitable for peers, not clients.
 clientJID :: Conn -> ClientState -> Text
@@ -769,13 +775,13 @@ clientJID con client = unsplitJID ( Just $ clientUser client
 -- | Send presence notification to subscribed peers.
 -- Note that a full JID from address will be added to the
 -- stanza if it is not present.
-informClientPresence :: PresenceState
+informClientPresence :: PresenceState stat
                         -> ClientAddress -> StanzaWrap (LockedChan Event) -> IO ()
 informClientPresence state k stanza = do
     forClient state k (return ()) $ \client -> do
     informClientPresence0 state (Just k) client stanza
 
-informClientPresence0 :: PresenceState
+informClientPresence0 :: PresenceState stat
                        -> Maybe ClientAddress
                        -> ClientState
                        -> StanzaWrap (LockedChan Event)
@@ -787,21 +793,21 @@ informClientPresence0 state mbk client stanza = do
     when (not is_avail) $ do
         atomically $ setClientFlag0 client cf_available
         maybe (return ()) (sendCachedPresence state) mbk
-    addrs <- subscribedPeers (clientUser client) (clientProfile client)
+    addrs <- subscribedPeers (manager state $ clientProfile client) (clientUser client) (clientProfile client)
     ktc <- atomically $ readTVar (pkeyToChan state)
     let connected = mapMaybe (flip Map.lookup ktc) addrs
     forM_ connected $ \con -> do
     let from' = clientJID con client
     mto <- runTraversableT $ do
             to <- liftT $ stanzaTo stanza
-            (to',_) <- liftMT $ rewriteJIDForPeer to
+            (to',_) <- liftMT $ rewriteJIDForPeer (manager state $ clientProfile client) to
             return to'
     dup <- cloneStanza stanza
     sendModifiedStanzaToPeer dup { stanzaFrom = Just from'
                                  , stanzaTo = mto }
                              (connChan con)
 
-informPeerPresence :: PresenceState
+informPeerPresence :: PresenceState stat
                     -> PeerAddress
                     -> StanzaWrap (LockedChan Event)
                     -> IO ()
@@ -874,7 +880,7 @@ informPeerPresence state k stanza = do
         froms <- case ctyp of
             Tox | clientProfile client == cprof -> return [from]
             _ -> do -- flip (maybe $ return [from]) k . const $ do
-                (_,trip) <- multiplyJIDForClient ck from
+                (_,trip) <- multiplyJIDForClient (manager state $ clientProfile client) ck from
                 return (map unsplitJID trip)
 
         dput XJabber $ "sending to client: " ++ show (stanzaType stanza,froms)
@@ -883,12 +889,12 @@ informPeerPresence state k stanza = do
         sendModifiedStanzaToClient (dup { stanzaFrom=Just from' })
                                    (connChan con)
 
-consoleClients :: PresenceState -> STM (Map Text ClientState)
+consoleClients :: PresenceState stat -> STM (Map Text ClientState)
 consoleClients PresenceState{ consoleWriter = Just cw } = readTVar (cwClients cw)
 consoleClients _                                        = return Map.empty
 
 
-answerProbe :: PresenceState -> Maybe Text -> PeerAddress -> TChan Stanza -> IO ()
+answerProbe :: PresenceState stat -> Maybe Text -> PeerAddress -> TChan Stanza -> IO ()
 answerProbe state mto k chan = do
     -- dput XJabber $ "answerProbe! " ++ show (stanzaType stanza)
     ktc <- atomically $ readTVar (pkeyToChan state)
@@ -911,7 +917,8 @@ answerProbe state mto k chan = do
     forM_ profiles $ \profile -> do
 
     -- only subscribed peers should get probe replies
-    resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u profile
+    let man = manager state $ cdProfile $ auxData conn
+    resolved_subs <- resolvedFromRoster man ConfigFiles.getSubscribers u profile
     let gaddrs = groupBy sameHost (sort resolved_subs)
         sameHost a b = (snd a == snd b) -- (==) `on` snd
         whitelist = do
@@ -951,13 +958,13 @@ answerProbe state mto k chan = do
 
 -- Send friend requests and remote presences stored in remotesByPeer to XMPP
 -- clients.
-sendCachedPresence :: PresenceState -> ClientAddress -> IO ()
+sendCachedPresence :: PresenceState stat -> ClientAddress -> IO ()
 sendCachedPresence state k = do
     forClient state k (return ()) $ \client -> do
     rbp <- atomically $ readTVar (remotesByPeer state)
     jids <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client)
     let hosts = map ((\(_,h,_)->h) . splitJID) jids
-    addrs <- resolveAllPeers hosts
+    addrs <- resolveAllPeers (manager state $ clientProfile client) hosts
     let onlines = rbp `Map.intersection` addrs
     mcon <- atomically $ do ktc <- readTVar (ckeyToChan state)
                             return $ Map.lookup k ktc
@@ -967,7 +974,7 @@ sendCachedPresence state k = do
         let h = peerKeyToText pk
         forM_ (Map.toList $ resources rp) $ \(resource,stanza) -> do
         let jid = unsplitJID (Just user,h,Just resource)
-        (mine,js) <- multiplyJIDForClient k jid
+        (mine,js) <- multiplyJIDForClient (manager state $ clientProfile client) k jid
         forM_ js $ \jid -> do
         let from' = unsplitJID jid
         dup <- cloneStanza stanza
@@ -988,37 +995,40 @@ sendCachedPresence state k = do
     return ()
 
 addToRosterFile ::
-                 (ConfigFiles.User
-                  -> ConfigFiles.Profile
-                  -> (L.ByteString -> IO (Maybe L.ByteString))
-                  -> Maybe L.ByteString
-                  -> t1)
+                 Connection.Manager s Text
+                 -> (ConfigFiles.User
+                      -> ConfigFiles.Profile
+                      -> (L.ByteString -> IO (Maybe L.ByteString))
+                      -> Maybe L.ByteString
+                      -> t1)
                  -> Text -- user
                  -> Text -- profile
                  -> Text -> [PeerAddress] -> t1
-addToRosterFile doit whose profile to addrs =
-    modifyRosterFile doit whose profile to addrs True
+addToRosterFile man doit whose profile to addrs =
+    modifyRosterFile man doit whose profile to addrs True
 
 removeFromRosterFile ::
-                      (ConfigFiles.User
-                       -> ConfigFiles.Profile
-                       -> (L.ByteString -> IO (Maybe L.ByteString))
-                       -> Maybe L.ByteString
-                       -> t1)
+                      Connection.Manager s Text
+                      -> (ConfigFiles.User
+                           -> ConfigFiles.Profile
+                           -> (L.ByteString -> IO (Maybe L.ByteString))
+                           -> Maybe L.ByteString
+                           -> t1)
                       -> Text -- user
                       -> Text -- profile
                       -> Text -> [PeerAddress] -> t1
-removeFromRosterFile doit whose profile to addrs =
-    modifyRosterFile doit whose profile to addrs False
+removeFromRosterFile man doit whose profile to addrs =
+    modifyRosterFile man doit whose profile to addrs False
 
 -- | Sanity-checked roster file manipulation.  Primarily, this function handles
 -- hostname aliases.
 modifyRosterFile ::
-                  (ConfigFiles.User
-                   -> ConfigFiles.Profile
-                   -> (L.ByteString -> IO (Maybe L.ByteString))
-                   -> Maybe L.ByteString
-                   -> t1)       -- ^ Lower-level modification function
+                  Connection.Manager s Text
+                   -> (ConfigFiles.User
+                       -> ConfigFiles.Profile
+                       -> (L.ByteString -> IO (Maybe L.ByteString))
+                       -> Maybe L.ByteString
+                       -> t1)   -- ^ Lower-level modification function
                                 --   indicating which file is being modified.
                                 --   Valid choices from ConfigFiles module:
                                 --
@@ -1035,7 +1045,7 @@ modifyRosterFile ::
                   -> [PeerAddress] -- ^ Alias addresses for hostname in the JID.
                   -> Bool       -- ^ True if adding, otherwise False
                   -> t1
-modifyRosterFile doit whose profile to addrs bAdd = do
+modifyRosterFile man doit whose profile to addrs bAdd = do
     let (mu,_,_) = splitJID to
         -- For each jid in the file, this function will decide whether to keep
         -- it (possibly modified) which is indicated by Just _ or to remove the
@@ -1046,7 +1056,7 @@ modifyRosterFile doit whose profile to addrs bAdd = do
                 keep   = return (Just jid) :: IO (Maybe L.ByteString)
                 delete = return Nothing    :: IO (Maybe L.ByteString)
                 iocheck  = do
-                    stored_addrs <- resolvePeer stored_h -- TODO: don't resolve .tox peers.
+                    stored_addrs <- resolvePeer man stored_h -- TODO: don't resolve .tox peers.
                     case stored_addrs of
                         []                      -> keep   -- do not delete if failed to resolve
                         xs | null (xs \\ addrs) -> delete -- hostname alias, delete
@@ -1063,7 +1073,7 @@ modifyRosterFile doit whose profile to addrs bAdd = do
          (guard bAdd >> Just (textToLazyByteString to))
 
 
-clientSubscriptionRequest :: PresenceState -> IO () -> ClientAddress -> Stanza -> TChan Stanza -> IO ()
+clientSubscriptionRequest :: PresenceState stat -> IO () -> ClientAddress -> Stanza -> TChan Stanza -> IO ()
 clientSubscriptionRequest state fail k stanza chan = do
     forClient state k fail $ \client -> do
     fromMaybe fail $ (splitJID <$> stanzaTo stanza) <&> \(mu,h,_) -> do
@@ -1071,6 +1081,7 @@ clientSubscriptionRequest state fail k stanza chan = do
     let to0   = unsplitJID (mu,h,Nothing) -- deleted resource
         cuser = clientUser client
         cprof = clientProfile client
+        man = manager state cprof
         mto = if ".tox" `Text.isSuffixOf` cprof
           then case parseNoSpamId to0 of
             Right toxjid@(NoSpamId nspam _)   -> Just ( Text.pack $ '$' : nospam64 nspam
@@ -1079,16 +1090,16 @@ clientSubscriptionRequest state fail k stanza chan = do
             Left _ | Text.isSuffixOf ".tox" h -> Nothing
             Left _ | Text.all isHexDigit h
                      && Text.length h == 76   -> Nothing
-            Left _ -> fmap (\u -> (u, to0 ,resolvePeer h)) mu
-          else fmap (\u -> (u, to0 ,resolvePeer h)) mu
+            Left _ -> fmap (\u -> (u, to0 ,resolvePeer man h)) mu
+          else fmap (\u -> (u, to0 ,resolvePeer man h)) mu
     fromMaybe fail $ mto <&> \(u,to,resolv) -> do
     -- add to-address to from's solicited
     dput XJabber $ unlines [ "to0=" ++ Text.unpack to0
                            , "to=" ++ show (Text.unpack to) ]
     addrs <- resolv
-    addToRosterFile      ConfigFiles.modifySolicited cuser cprof to addrs
-    removeFromRosterFile ConfigFiles.modifyBuddies   cuser cprof to addrs
-    resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers cuser cprof
+    addToRosterFile      man ConfigFiles.modifySolicited cuser cprof to addrs
+    removeFromRosterFile man ConfigFiles.modifyBuddies   cuser cprof to addrs
+    resolved_subs <- resolvedFromRoster man ConfigFiles.getSubscribers cuser cprof
     let is_subscribed = not . null $ [ (mu, a) | a <- addrs ]
                                      `intersect` resolved_subs
     -- subscribers: "from"
@@ -1100,8 +1111,7 @@ clientSubscriptionRequest state fail k stanza chan = do
         (cktc,pktc,(sv,conns)) <- atomically $ do
             cktc <- readTVar $ ckeyToChan state
             pktc <- readTVar $ pkeyToChan state
-            sc <- takeTMVar svVar
-            return (cktc,pktc,sc)
+            return (cktc,pktc,(server state,man))
 
         -- Update roster for each client.
         case stanzaType stanza of
@@ -1132,7 +1142,7 @@ clientSubscriptionRequest state fail k stanza chan = do
                 from = unsplitJID ( Just $ clientUser client
                                   , (\(Local a) -> addrToText a) $ laddr
                                   , Nothing )
-            mb <- rewriteJIDForPeer to
+            mb <- rewriteJIDForPeer (manager state $ cdProfile $ auxData con) to
             forM_ mb $ \(to',addr) -> do
             dup <- cloneStanza stanza
             sendModifiedStanzaToPeer (dup { stanzaTo = Just to'
@@ -1145,9 +1155,8 @@ clientSubscriptionRequest state fail k stanza chan = do
                 Just $ Connection.setPolicy (toxConnections toxman) (ToxContact meid themid)
         -- Add peer if we are not already associated ...
         policySetter Connection.TryingToConnect
-        atomically $ putTMVar svVar (sv,conns)
 
-weAreTox :: PresenceState -> ClientState -> Text -> Maybe (ToxManager ClientAddress,Text{- me -},Text{- them -})
+weAreTox :: PresenceState stat -> ClientState -> Text -> Maybe (ToxManager ClientAddress,Text{- me -},Text{- them -})
 weAreTox state client h = do
     toxman <- toxManager state
     (me  , ".tox") <- Just $ Text.splitAt 43 (clientProfile client)
@@ -1155,20 +1164,21 @@ weAreTox state client h = do
     return (toxman,me,them)
 
 resolvedFromRoster
-  :: (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString])
+  :: Connection.Manager s Text
+     -> (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString])
      -> UserName -> Text -> IO [(Maybe UserName, PeerAddress)]
-resolvedFromRoster doit u profile = do
+resolvedFromRoster man doit u profile = do
     subs <- configText doit u profile
     runTraversableT $ do
             (mu,h,_) <- liftT $ splitJID `fmap` subs
-            addr <- liftMT $ fmap nub $ resolvePeer h
+            addr <- liftMT $ fmap nub $ resolvePeer man h
             return (mu,addr)
 
-clientCons :: PresenceState
+clientCons :: PresenceState stat
             -> Map ClientAddress t -> Text -> IO [(t, ClientState)]
 clientCons state ktc u = map snd <$> clientCons' state ktc u
 
-clientCons' :: PresenceState
+clientCons' :: PresenceState stat
             -> Map ClientAddress t -> Text -> IO [(ClientAddress,(t, ClientState))]
 clientCons' state ktc u = do
     mlp <- atomically $ do
@@ -1188,7 +1198,7 @@ releventProfiles ctyp user = do
     -- .presence/ directory.
     return []
 
-peerSubscriptionRequest :: PresenceState -> IO () -> PeerAddress -> Stanza -> TChan Stanza -> IO ()
+peerSubscriptionRequest :: PresenceState stat -> IO () -> PeerAddress -> Stanza -> TChan Stanza -> IO ()
 peerSubscriptionRequest state fail k stanza chan = do
     dput XJabber $ "Handling pending subscription from remote"
     fromMaybe fail $ (stanzaFrom stanza) <&> \from -> do
@@ -1207,12 +1217,12 @@ peerSubscriptionRequest state fail k stanza chan = do
     (mine,totup) <- case (ctyp,profile) of
         (Tox,p) -> let (u,h,r) = splitJID to
                    in return ( h == p, (u,h,r) )
-        _       -> rewriteJIDForClient laddr to []
+        _       -> rewriteJIDForClient (manager state profile) laddr to []
     if not mine then fail else do
-    (_,fromtup) <- rewriteJIDForClient laddr from []
+    (_,fromtup) <- rewriteJIDForClient (manager state profile) laddr from []
     fromMaybe fail $ mto_u <&> \u -> do
     fromMaybe fail $ mfrom_u <&> \from_u -> do
-    resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u profile
+    resolved_subs <- resolvedFromRoster (manager state profile) ConfigFiles.getSubscribers u profile
     let already_subscribed = elem (mfrom_u,k) resolved_subs
         is_wanted = case stanzaType stanza of
                       PresenceRequestSubscription b -> b
@@ -1233,7 +1243,7 @@ peerSubscriptionRequest state fail k stanza chan = do
     -- TODO: if peer-connection is to self, then auto-approve local user.
 
     -- add from-address to to's pending
-    addrs <- resolvePeer from_h
+    addrs <- resolvePeer (manager state profile) from_h
 
     -- Catch exception in case the user does not exist
     if null addrs then fail else do
@@ -1243,9 +1253,9 @@ peerSubscriptionRequest state fail k stanza chan = do
     -- Update roster files (subscribe: add to pending, unsubscribe: remove from subscribers).
     already_pending <-
       if is_wanted then
-        addToRosterFile ConfigFiles.modifyPending u profile from' addrs
+        addToRosterFile (manager state profile) ConfigFiles.modifyPending u profile from' addrs
       else do
-        removeFromRosterFile ConfigFiles.modifySubscribers u profile from' addrs
+        removeFromRosterFile (manager state profile) ConfigFiles.modifySubscribers u profile from' addrs
         reply <- makeInformSubscription "jabber:server" to from is_wanted
         sendModifiedStanzaToPeer reply chan
         return False
@@ -1270,7 +1280,7 @@ myMakeRosterUpdate prf tojid contact as
 myMakeRosterUpdate _ tojid contact as = XMPPServer.makeRosterUpdate tojid contact as
 
 
-clientInformSubscription :: PresenceState
+clientInformSubscription :: PresenceState stat
                           -> IO ()
                           -> ClientAddress
                           -> StanzaWrap (LockedChan Event)
@@ -1280,11 +1290,12 @@ clientInformSubscription state fail k stanza = do
     fromMaybe fail $ (stanzaTo stanza) <&> \to -> do
     dput XJabber $ "clientInformSubscription"
     let (mu,h,mr) = splitJID to
-    addrs <- resolvePeer h
+        man = manager state $ clientProfile client
+    addrs <- resolvePeer man h
     -- remove from pending
-    buds <- resolvedFromRoster ConfigFiles.getBuddies (clientUser client) (clientProfile client)
+    buds <- resolvedFromRoster man ConfigFiles.getBuddies (clientUser client) (clientProfile client)
     let is_buddy = not . null $ map (mu,) addrs `intersect` buds
-    removeFromRosterFile ConfigFiles.modifyPending (clientUser client) (clientProfile client) to addrs
+    removeFromRosterFile man ConfigFiles.modifyPending (clientUser client) (clientProfile client) to addrs
     let (relationship,addf,remf) =
          case stanzaType stanza of
            PresenceInformSubscription True ->
@@ -1296,8 +1307,8 @@ clientInformSubscription state fail k stanza = do
                                                else "none" )
                 , ConfigFiles.modifyOthers
                 , ConfigFiles.modifySubscribers )
-    addToRosterFile      addf (clientUser client) (clientProfile client) to addrs
-    removeFromRosterFile remf (clientUser client) (clientProfile client) to addrs
+    addToRosterFile      man addf (clientUser client) (clientProfile client) to addrs
+    removeFromRosterFile man remf (clientUser client) (clientProfile client) to addrs
 
     do
         cbu <- atomically $ readTVar (clientsByUser state)
@@ -1335,7 +1346,7 @@ clientInformSubscription state fail k stanza = do
                                  (connChan con)
         answerProbe state (Just from) pk (connChan con)
 
-peerInformSubscription :: PresenceState
+peerInformSubscription :: PresenceState stat
                         -> IO ()
                         -> PeerAddress
                         -> StanzaWrap (LockedChan Event)
@@ -1352,9 +1363,10 @@ peerInformSubscription state fail k stanza = do
     fromMaybe fail $ Map.lookup k ktc
         <&> \(Conn { connChan=sender_chan
                    , auxData =ConnectionData (Left laddr) ctyp profile _ }) -> do
+    let man = manager state profile
     (from_u,from_h,_) <- case ctyp of
         Tox  -> return $ splitJID from
-        XMPP -> snd <$> rewriteJIDForClient laddr from []
+        XMPP -> snd <$> rewriteJIDForClient man laddr from []
     let from'' = unsplitJID (from_u,from_h,Nothing)
         muser = do
             to <- stanzaTo stanza
@@ -1365,10 +1377,10 @@ peerInformSubscription state fail k stanza = do
     -- This would allow us to answer anonymous probes with 'unsubscribed'.
     fromMaybe fail $ muser <&> \user -> do
 
-    addrs <- resolvePeer from_h
-    was_solicited <- removeFromRosterFile ConfigFiles.modifySolicited user profile from'' addrs
+    addrs <- resolvePeer man from_h
+    was_solicited <- removeFromRosterFile man ConfigFiles.modifySolicited user profile from'' addrs
 
-    subs <- resolvedFromRoster ConfigFiles.getSubscribers user profile
+    subs <- resolvedFromRoster man ConfigFiles.getSubscribers user profile
     let is_sub = not . null $ map (from_u,) addrs `intersect` subs
     dput XJabber $ "DEBUG peerInformSubscription (is_sub,typ)=" ++ show (is_sub,stanzaType stanza)
     let (relationship,addf,remf) =
@@ -1382,8 +1394,8 @@ peerInformSubscription state fail k stanza = do
                                              else "none")
                 , ConfigFiles.modifyOthers
                 , ConfigFiles.modifyBuddies )
-    addToRosterFile      addf user profile from'' addrs
-    removeFromRosterFile remf user profile from'' addrs
+    addToRosterFile      man addf user profile from'' addrs
+    removeFromRosterFile man remf user profile from'' addrs
 
     chans <- clientCons' state cktc user
     forM_ chans $ \(ckey,(Conn { connChan=chan }, client)) -> do
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index bb0cc912..02c33635 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE ExistentialQuantification #-}
 module XMPPServer
     ( xmppServer
+    , forkXmpp
     , quitXmpp
     , ClientAddress
     , PeerAddress
@@ -42,8 +43,6 @@ module XMPPServer
     , greet'
     , (<&>)
     , grokStanza
-    , Uniq24(..)
-    , uniqueAsKey
     ) where
 
 import ConnectionKey
@@ -53,7 +52,7 @@ import Connection.Tcp
 import EventUtil
 import ControlMaybe
 import LockedChan
-import PeerResolve
+import Connection (PeerAddress(..))
 import qualified Connection
 import Util
 import Network.Address (getBindAddress, sockAddrPort)
@@ -66,9 +65,9 @@ import Control.Monad.IO.Class (MonadIO, liftIO)
 import Control.Monad.Fix (fix)
 import Control.Monad
 #ifdef THREAD_DEBUG
-import Control.Concurrent.Lifted.Instrument (forkIO,myThreadId,labelThread)
+import Control.Concurrent.Lifted.Instrument (forkIO,myThreadId,labelThread,ThreadId)
 #else
-import Control.Concurrent.Lifted (forkIO,myThreadId)
+import Control.Concurrent.Lifted (forkIO,myThreadId,ThreadId)
 import GHC.Conc                  (labelThread)
 #endif
 import Control.Concurrent.STM
@@ -90,6 +89,7 @@ import Data.Conduit.Blaze (builderToByteStringFlush)
 #endif
 import Control.Monad.Catch (MonadThrow)
 
+import DNSCache (withPort)
 import qualified Text.XML.Stream.Render as XML hiding (content)
 import qualified Text.XML.Stream.Parse as XML
 import Data.XML.Types as XML
@@ -1250,9 +1250,9 @@ slotsToSource slots nesting lastStanza needsFlush rdone =
                 ,readTMVar rdone >> return (return ())
                 ]
 
-forkConnection :: Server SockAddr ConnectionData releaseKey XML.Event
+forkConnection :: Server PeerAddress ConnectionData releaseKey XML.Event
                 -> XMPPServerParameters
-                -> SockAddr -- SockAddr (remote for peer, local for client)
+                -> PeerAddress -- SockAddr (XXX(what?): remote for peer, local for client)
                 -> ConnectionData
                 -> FlagCommand
                 -> Source IO XML.Event
@@ -1262,12 +1262,12 @@ forkConnection :: Server SockAddr ConnectionData releaseKey XML.Event
 forkConnection sv xmpp saddr cdta pingflag src snk stanzas = do
     let auxAddr = cdAddr cdta
         clientOrServer@(namespace,tellmyname,telltheirname,_) = case auxAddr of
-            Right _    -> ("jabber:client", xmppTellMyNameToClient xmpp (ClientAddress saddr)
-                                          , xmppTellClientHisName xmpp (ClientAddress saddr)
-                                          , ClientOrigin (ClientAddress saddr))
+            Right _    -> ("jabber:client", xmppTellMyNameToClient xmpp (ClientAddress $ peerAddress saddr)
+                                          , xmppTellClientHisName xmpp (ClientAddress $ peerAddress saddr)
+                                          , ClientOrigin (ClientAddress $ peerAddress saddr))
             Left laddr -> ("jabber:server", xmppTellMyNameToPeer xmpp laddr
-                                          , xmppTellPeerHisName xmpp (PeerAddress saddr)
-                                          , PeerOrigin (PeerAddress saddr))
+                                          , xmppTellPeerHisName xmpp saddr
+                                          , PeerOrigin saddr)
     me <- tellmyname
     rdone <- atomically newEmptyTMVar
     let isStarter (Left _) = True
@@ -1427,7 +1427,7 @@ data PeerState
     | PeerConnected (TChan Stanza)
 -}
 
-peerKey :: SocketLike sock => Maybe SockAddr -> sock -> IO (SockAddr,ConnectionData)
+peerKey :: SocketLike sock => Maybe SockAddr -> sock -> IO (PeerAddress,ConnectionData)
 peerKey bind_addr sock = do
     laddr <- getSocketName sock
     raddr <-
@@ -1441,13 +1441,13 @@ peerKey bind_addr sock = do
                                        -- to distinguish fake address connection keys.
                         return p
     rname <- atomically $ newTVar Nothing
-    return $ ( raddr `withPort` peerport
+    return $ ( PeerAddress $ raddr `withPort` peerport
              , ConnectionData { cdAddr       = Left (Local laddr)
                               , cdType       = XMPP
                               , cdProfile    = "."
                               , cdRemoteName = rname } )
 
-clientKey :: SocketLike sock => sock -> IO (SockAddr,ConnectionData)
+clientKey :: SocketLike sock => sock -> IO (PeerAddress,ConnectionData)
 clientKey sock = do
     laddr <- getSocketName sock
     raddr <- getPeerName sock
@@ -1457,27 +1457,13 @@ clientKey sock = do
                             , "is using port zero.  This could interfere"
                             , "with Tox peer sessions." ]
     rname <- atomically $ newTVar Nothing
-    return $ ( laddr
+    return $ ( PeerAddress laddr
              , ConnectionData { cdAddr       = Right (Remote raddr)
                               , cdType       = XMPP
                               , cdProfile    = "."
                               , cdRemoteName = rname } )
 
 
-data Uniq24 = Uniq24 !Word64 !Word64 !Word64
- deriving (Eq,Ord,Show)
-
-uniqueAsKey :: Uniq24 -> SockAddr
-uniqueAsKey (Uniq24 x y z) = SockAddrInet6 (fromIntegral 0) a bcde f
- where
-    a = fromIntegral (x `shiftR` 32)
-    b = fromIntegral x
-    c = fromIntegral (y `shiftR` 32)
-    d = fromIntegral y
-    e = fromIntegral (z `shiftR` 32)
-    f = fromIntegral z
-    bcde = (b,c,d,e)
-
 xmlifyRosterItems :: Monad m => Set Text -> Text -> Set Text -> ConduitM i Event m ()
 xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set)
  where
@@ -1544,10 +1530,10 @@ sendRoster query xmpp clientKey replyto = do
     -}
 
 
-socketFromKey :: Server SockAddr ConnectionData releaseKey XML.Event -> ClientAddress -> IO (Remote SockAddr)
+socketFromKey :: Server PeerAddress ConnectionData releaseKey XML.Event -> ClientAddress -> IO (Remote SockAddr)
 socketFromKey sv (ClientAddress addr) = do
     map <- atomically $ readTVar (conmap sv)
-    let mcd = Map.lookup addr map
+    let mcd = Map.lookup (PeerAddress addr) map
         oops = Remote addr -- No connection data, so using incorrect address.
     case mcd of
         Nothing -> return oops
@@ -1711,8 +1697,8 @@ makeErrorStanza stanza = do
            ]
 
 monitor ::
-    Server SockAddr ConnectionData releaseKey XML.Event
-    -> ConnectionParameters SockAddr ConnectionData
+    Server PeerAddress ConnectionData releaseKey XML.Event
+    -> ConnectionParameters PeerAddress ConnectionData
     -> XMPPServerParameters
     -> IO b
 monitor sv params xmpp = do
@@ -1726,15 +1712,19 @@ monitor sv params xmpp = do
             Connection pingflag xsrc xsnk
                 -> do wlog $ tomsg addr "Connection"
                       outs <- forkConnection sv xmpp addr u pingflag xsrc xsnk stanzas
-                      xmppNewConnection xmpp addr u outs
+                      -- /addr/ may be a peer or a client.  So we'll strip off
+                      -- the PeerAddress constructor before exposing it.
+                      xmppNewConnection xmpp (peerAddress addr) u outs
             ConnectFailure addr
                 -> do return () -- wlog $ tomsg k "ConnectFailure"
             EOF -> do wlog $ tomsg addr "EOF"
-                      xmppEOF xmpp addr u
+                      -- /addr/ may be a peer or a client.  So we'll strip off
+                      -- the PeerAddress constructor before exposing it.
+                      xmppEOF xmpp (peerAddress addr) u
             HalfConnection In
                 -> do wlog $ tomsg addr "ReadOnly"
                       case cdAddr u of
-                        Left (Local _) -> control sv (Connect addr params)
+                        Left (Local _) -> control sv (Connect (peerAddress addr) params)
                         _              -> return () -- Don't call-back client connections.
             HalfConnection Out
                 -> do wlog $ tomsg addr "WriteOnly"
@@ -1912,55 +1902,66 @@ classifyConnection saddr dta = case cdAddr dta of
 
 data XMPPServer
     = forall releaseKey.
-      XMPPServer { _xmpp_sv :: Server SockAddr ConnectionData releaseKey XML.Event
-                 , _xmpp_peer_params :: ConnectionParameters SockAddr ConnectionData
+      XMPPServer { _xmpp_sv          :: Server PeerAddress ConnectionData releaseKey XML.Event
+                                        -- ^ Internally, we're using PeerAddress for both clients
+                                        -- and peers.  For the external interface, we mark client
+                                        -- addresses as 'ClientAddress' and not 'PeerAddress'.
+                 , _xmpp_man         :: Connection.Manager TCPStatus Text
+                 , _xmpp_peer_params :: ConnectionParameters PeerAddress ConnectionData
+                 , _xmpp_peer_bind   :: SockAddr
                  }
 
-grokPeer :: XMPPServer -> SockAddr -> (SockAddr, ConnectionParameters SockAddr ConnectionData, Miliseconds)
-grokPeer sv addr = (addr, _xmpp_peer_params sv, 10000)
-
-
 xmppConnections :: XMPPServer -> IO (Connection.Manager TCPStatus Text)
-xmppConnections xsv@XMPPServer{_xmpp_sv=sv} = tcpManager (grokPeer xsv) (Just . Text.pack) resolve sv
- where
-    resolve :: Text -> IO (Maybe SockAddr)
-    resolve hostname = listToMaybe . map (\(PeerAddress addr) -> addr) <$> resolvePeer hostname
+xmppConnections xsv@XMPPServer{_xmpp_man = m} = return m
 
-xmppEventChannel :: XMPPServer -> TChan ((SockAddr, ConnectionData), ConnectionEvent Event)
+xmppEventChannel :: XMPPServer -> TChan ((PeerAddress, ConnectionData), ConnectionEvent Event)
 xmppEventChannel XMPPServer{_xmpp_sv=sv} = serverEvent sv
 
 quitXmpp :: XMPPServer -> IO ()
 quitXmpp XMPPServer{_xmpp_sv=sv} = control sv Quit
 
-xmppServer :: MonadIO m =>
-              Allocate releaseKey m -> XMPPServerParameters -> m XMPPServer
-xmppServer allocate xmpp = do
+xmppServer :: MonadIO m => Allocate releaseKey m
+                        -> Maybe SockAddr -- ^ Listen address for server-to-server protocol.
+                        -> m XMPPServer
+xmppServer allocate bind_addr = do
     sv <- server allocate xmlStream
-    -- some fuzz helps avoid simultaneity
-    pingfuzz <- liftIO $ do
+    liftIO $ do
         gen <- System.Random.getStdGen
+        peer_bind <- maybe (getBindAddress "5269" True) return bind_addr
         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 $ xmppPeerBind xmpp)
-                          { pingInterval = 15000 + pingfuzz
-                          , timeout = 2000
-                          , duplex = False }
-        client_params = (connectionDefaults clientKey)
-                          { pingInterval = 0
-                          , timeout = 0
+            fuzz = r `mod` 2000 -- maximum 2 seconds of ping fuzz
+            peer_params :: ConnectionParameters PeerAddress ConnectionData
+            peer_params = (connectionDefaults $ peerKey $ Just peer_bind)
+                              { pingInterval = 15000 + fuzz
+                              , timeout      = 2000
+                              , duplex       = False }
+        tcp <- tcpManager (\(PeerAddress addr) -> (addr, peer_params, 10000)) sv
+        return XMPPServer { _xmpp_sv          = sv
+                          , _xmpp_man         = tcp
+                          , _xmpp_peer_params = peer_params
+                          , _xmpp_peer_bind   = peer_bind
                           }
-    liftIO $ do
-        forkIO $ do
-            myThreadId >>= flip labelThread ("XMPP.monitor")
-            monitor sv peer_params xmpp
-        dput XMisc $ "Starting peer listen"
-        peer_bind <- maybe (getBindAddress "5269" True) return $ xmppPeerBind xmpp
-        control sv (Listen peer_bind peer_params)
-        dput XMisc $ "Starting client listen"
-        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 }
+
+forkXmpp :: MonadIO m => XMPPServer -> XMPPServerParameters -> m ThreadId
+forkXmpp XMPPServer { _xmpp_sv          = sv
+                    , _xmpp_peer_params = peer_params
+                    , _xmpp_peer_bind   = peer_bind
+                    }
+         xmpp = liftIO $ do
+    let client_params :: ConnectionParameters PeerAddress ConnectionData
+        client_params = (connectionDefaults clientKey)
+                              { pingInterval = 0
+                              , timeout      = 0
+                              }
+    mt <- forkIO $ do myThreadId >>= flip labelThread ("XMPP.monitor")
+                      monitor sv peer_params xmpp
+    dput XMisc $ "Starting peer listen"
+    control sv (Listen peer_bind peer_params)
+    dput XMisc $ "Starting client listen"
+    client_bind <- maybe (getBindAddress "5222" True) return $ xmppClientBind xmpp
+    control sv (Listen client_bind client_params)
+    return mt
+
 
 #if MIN_VERSION_stm(2,4,0)
 #else
diff --git a/ToxManager.hs b/ToxManager.hs
index 78049010..2aeff620 100644
--- a/ToxManager.hs
+++ b/ToxManager.hs
@@ -9,6 +9,7 @@ module ToxManager where
 import Announcer
 import Announcer.Tox
 import ClientState
+import Control.Arrow
 import Control.Concurrent.STM
 import Control.Monad
 import Crypto.Tox
@@ -57,6 +58,7 @@ import GHC.Conc                  (labelThread)
 #endif
 import GHC.Conc                  (unsafeIOToSTM)
 import Connection
+import Connection.Tcp (TCPStatus)
 
 
 toxAnnounceSendData :: Tox.Tox JabberClients
@@ -91,7 +93,7 @@ toxman :: TVar (Map.Map Uniq24 AggregateSession)
             -> Announcer
             -> [(String,TVar (BucketList Tox.NodeInfo))]
             -> Tox.Tox JabberClients
-            -> PresenceState
+            -> PresenceState TCPStatus
             -> ToxManager ClientAddress
 toxman ssvar announcer toxbkts tox presence = ToxManager
     { activateAccount        = \k pubname seckey -> do
@@ -197,6 +199,18 @@ toxman ssvar announcer toxbkts tox presence = ToxManager
      , stringToKey = stringToKey_
      , showProgress = show
      , showKey = show
+     , resolvePeer = \(ToxContact me them) -> do
+            let mek   = id2key me
+                themk = id2key them
+            u <- xor24 <$> hash24 mek <*> hash24 themk
+            return [uniqueAsKey u]
+     , reverseAddress = \paddr -> atomically $ do
+        -- This will only succeed if there is an established session.
+        -- TODO: Is that sufficient?
+        ss <- readTVar ssvar
+        m <- forM (keyAsUnique paddr >>= (`Map.lookup` ss)) $ \c -> do
+            fmap (uncurry ToxContact . (key2id *** key2id)) <$> compatibleKeys c
+        return $ maybeToList (join m)
      }
     , resolveToxPeer = \me them -> do
         let m = do meid <- readMaybe $ T.unpack me
@@ -204,7 +218,7 @@ toxman ssvar announcer toxbkts tox presence = ToxManager
                    return (id2key meid, id2key themid)
         forM m $ \(me,them) -> do
             u <- xor24 <$> hash24 me <*> hash24 them
-            return $ addrToPeerKey $ Remote $ uniqueAsKey u
+            return $ addrToPeerKey $ Remote $ peerAddress $ uniqueAsKey u
     }
 
 key2jid :: Word32 -> PublicKey -> Text
@@ -231,7 +245,7 @@ initPerClient = do
 data ToxToXMPP = ToxToXMPP
     { txAnnouncer      :: Announcer
     , txAccount        :: Account JabberClients
-    , txPresence       :: PresenceState
+    , txPresence       :: PresenceState TCPStatus
     , txTox            :: Tox JabberClients
     , txSessions       :: TVar (Map.Map Uniq24 AggregateSession)
     }
@@ -510,7 +524,7 @@ akeyConnect announcer me them =
 -- | Returns a list of nospam values to use for friend requests to send to a
 -- remote peer.  This list is non-empty only when it is desirable to send
 -- friend requests.
-checkSoliciting :: PresenceState -> PublicKey -> PublicKey -> Contact -> IO [NoSpam]
+checkSoliciting :: PresenceState TCPStatus -> PublicKey -> PublicKey -> Contact -> IO [NoSpam]
 checkSoliciting presence me them contact = do
     let theirhost = T.pack $ show (key2id them) ++ ".tox"
         myhost = T.pack $ show (key2id me) ++ ".tox"
@@ -616,7 +630,7 @@ stopConnecting ToxToXMPP{txAnnouncer=announcer,txAccount=acnt} them reason = do
     cancel announcer akeyD
 
 forkAccountWatcher :: TVar (Map.Map Uniq24 AggregateSession)
-                      -> Account JabberClients -> Tox JabberClients -> PresenceState -> Announcer -> IO ThreadId
+                      -> Account JabberClients -> Tox JabberClients -> PresenceState TCPStatus -> Announcer -> IO ThreadId
 forkAccountWatcher ssvar acc tox st announcer = forkIO $ do
     myThreadId >>= flip labelThread ("online:"
                                       ++ show (key2id $ toPublic $ userSecret acc))
diff --git a/dht-client.cabal b/dht-client.cabal
index 8b876605..e5df9a7a 100644
--- a/dht-client.cabal
+++ b/dht-client.cabal
@@ -132,7 +132,6 @@ library
                     Logging
                     Nesting
                     Paths
-                    PeerResolve
                     Connection.Tcp
                     SockAddr
                     TraversableT
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 34b555f5..d397730b 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -2009,8 +2009,7 @@ main = do
             sport <- getBindAddress (portxmppS opts) True{-IPv6 supported-}
 
             -- XMPP initialization
-            cw        <- newConsoleWriter
-            serverVar <- atomically $ newEmptyTMVar
+            cw <- newConsoleWriter
             let lookupBkts :: String -> Map.Map String DHT -> Maybe (String,TVar (BucketList Tox.NodeInfo))
                 lookupBkts name m = case Map.lookup name m of
                     Nothing              -> Nothing
@@ -2020,16 +2019,12 @@ main = do
                             , lookupBkts "tox6" toxdhts
                             ]
 
+            sv <- xmppServer Tcp.noCleanUp (Just sport)
+            tcp <- xmppConnections sv -- :: IO ( Manager TCPStatus T.Text )
             let tman = toxman ssvar announcer toxbkts <$> mbtox
-            state     <- newPresenceState cw tman serverVar
-
-            sv    <- xmppServer Tcp.noCleanUp (presenceHooks state (verbosity opts) (Just cport) (Just sport))
-            -- We now have a server object but it's not ready to use until
-            -- we put it into the 'server' field of our /state/ record.
+            state     <- newPresenceState cw tman sv (const tcp)
+            forkXmpp sv (presenceHooks state (verbosity opts) (Just cport) (Just sport))
             conns     <- xmppConnections  sv
-            atomically $ do
-                putTMVar serverVar  (sv,conns) -- Okay, now it's ready. :)
-                                               -- FIXME: This is error prone.
             return (Just sv, Just conns, Just state)
 
     forM_ (take 1 taddrs) $ \addrTox -> do
@@ -2151,8 +2146,7 @@ main = do
     -- Use ResourceT to clean-up XMPP server.
     waitForSignal
 
-    forM_ mstate $ \PresenceState{server=tmvar} -> do
-        xmpp <- fst <$> atomically (readTMVar tmvar)
+    forM_ mstate $ \PresenceState{server=xmpp} -> do
         quitXmpp xmpp
     stopAnnouncer announcer
     quitBt
diff --git a/src/Network/Tox/AggregateSession.hs b/src/Network/Tox/AggregateSession.hs
index d4497c48..26e7153a 100644
--- a/src/Network/Tox/AggregateSession.hs
+++ b/src/Network/Tox/AggregateSession.hs
@@ -9,6 +9,7 @@ module Network.Tox.AggregateSession
     , newAggregateSession
     , aggregateStatus
     , checkCompatible
+    , compatibleKeys
     , AddResult(..)
     , addSession
     , DelResult(..)
@@ -321,3 +322,16 @@ checkCompatible me them c = do
                     con:_        -> Just $ ncTheirPublicKey (singleSession con)   == them
                                            && (ncMyPublicKey $ singleSession con) == me
                     []           -> Nothing
+
+-- | Returns the local and remote keys that are compatible with this aggregate.
+-- If 'Nothing' Is returned, then either no key is compatible ('closeAll' was
+-- called) or all keys are compatible because no sessions have been associated.
+compatibleKeys :: AggregateSession -> STM (Maybe (PublicKey,PublicKey))
+compatibleKeys c = do
+    isclosed <- isClosedTMChan (contactChannel c)
+    imap <- readTVar (contactSession c)
+    return $ case IntMap.elems imap of
+                    _ | isclosed -> Nothing -- none.
+                    con:_        -> Just ( ncMyPublicKey $ singleSession con
+                                         , ncTheirPublicKey (singleSession con))
+                    []           -> Nothing -- any.