9 files changed, 409 insertions, 342 deletions

diff --git a/Presence/ConnectionKey.hs b/Presence/ConnectionKey.hs
index 944f4f6f..f0180455 100644
--- a/Presence/ConnectionKey.hs
+++ b/Presence/ConnectionKey.hs
@@ -3,8 +3,9 @@ module ConnectionKey where
 import Network.Socket ( SockAddr(..) )
 import SockAddr ()
 
-data ConnectionKey
-       = PeerKey { callBackAddress :: SockAddr }
-       | ClientKey { localAddress :: SockAddr }
- deriving (Show, Ord, Eq)
+newtype PeerAddress = PeerAddress SockAddr
+    deriving (Eq,Ord,Show)
+
+newtype ClientAddress = ClientAddress SockAddr
+    deriving (Eq,Ord,Show)
 
diff --git a/Presence/DNSCache.hs b/Presence/DNSCache.hs
index ce35752e..c5154e34 100644
--- a/Presence/DNSCache.hs
+++ b/Presence/DNSCache.hs
@@ -17,6 +17,7 @@ module DNSCache
     , forwardResolve
     , newDNSCache
     , parseAddress
+    , unsafeParseAddress
     , strip_brackets
     , withPort
     ) where
@@ -27,6 +28,7 @@ import Control.Concurrent.Lifted.Instrument
 import Control.Concurrent.Lifted
 import GHC.Conc                  (labelThread)
 #endif
+import Control.Arrow
 import Control.Concurrent.STM
 import Data.Text       ( Text )
 import Network.Socket  ( SockAddr(..), AddrInfoFlag(..), defaultHints, getAddrInfo, AddrInfo(..) )
@@ -44,6 +46,7 @@ import Data.List
 import Data.Ord
 import Data.Maybe
 import System.IO.Error
+import System.IO.Unsafe
 
 import SockAddr      ()
 import ControlMaybe  ( handleIO_ )
@@ -144,7 +147,7 @@ rawForwardResolve dns onFail timeout addrtext = do
       return ()
 
 strip_brackets :: Text -> Text
-strip_brackets s = 
+strip_brackets s =
       case Text.uncons s of
           Just ('[',t) -> Text.takeWhile (/=']') t
           _            -> s
@@ -265,6 +268,23 @@ parseAddress addr_str = do
     return . listToMaybe $ map addrAddress info
 
 
+splitAtPort :: String -> (String,String)
+splitAtPort s = second sanitizePort $ case s of
+    ('[':t) -> break (==']') t
+    _       -> break (==':') s
+ where
+    sanitizePort (']':':':p) = p
+    sanitizePort (':':p)     = p
+    sanitizePort _           = "0"
+
+unsafeParseAddress :: String -> Maybe SockAddr
+unsafeParseAddress addr_str = unsafePerformIO $ do
+    let (ipstr,portstr) = splitAtPort addr_str
+    info <- getAddrInfo (Just $ defaultHints { addrFlags = [ AI_NUMERICHOST ] })
+                        (Just ipstr)
+                        (Just portstr)
+    return . listToMaybe $ map addrAddress info
+
 withPort :: SockAddr -> Int -> SockAddr
 withPort (SockAddrInet _ a)      port = SockAddrInet (toEnum port) a
 withPort (SockAddrInet6 _ a b c) port = SockAddrInet6 (toEnum port) a b c
diff --git a/Presence/PeerResolve.hs b/Presence/PeerResolve.hs
index 900688c3..62becfe1 100644
--- a/Presence/PeerResolve.hs
+++ b/Presence/PeerResolve.hs
@@ -2,6 +2,7 @@ module PeerResolve
     ( peerKeyToResolvedNames
     , resolvePeer
     , parseAddress
+    , unsafeParseAddress
     , strip_brackets
     , withPort
     ) where
@@ -17,11 +18,10 @@ import ConnectionKey
 global_dns_cache :: DNSCache
 global_dns_cache = unsafePerformIO $ newDNSCache
 
-resolvePeer :: Text -> IO [SockAddr]
-resolvePeer addrtext = forwardResolve global_dns_cache addrtext
+resolvePeer :: Text -> IO [PeerAddress]
+resolvePeer addrtext = map PeerAddress <$> forwardResolve global_dns_cache addrtext
 
-peerKeyToResolvedNames :: ConnectionKey -> IO [Text]
-peerKeyToResolvedNames k@(ClientKey { localAddress=addr }) = return []
-peerKeyToResolvedNames k@(PeerKey { callBackAddress=addr }) = do
-    reverseResolve global_dns_cache addr
+peerKeyToResolvedNames :: PeerAddress -> IO [Text]
+peerKeyToResolvedNames (PeerAddress addr)
+    = reverseResolve global_dns_cache addr
 
diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index af6597b6..244bbead 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -53,11 +53,13 @@ import Network.Tox.NodeId (key2id)
 import Crypto.Tox (decodeSecret)
 import DPut
 
-isPeerKey :: ConnectionKey -> Bool
+{-
+isPeerKey :: ClientAddress -> Bool
 isPeerKey k = case k of { PeerKey {} -> True ; _ -> False }
 
-isClientKey :: ConnectionKey -> Bool
+isClientKey :: ClientAddress -> Bool
 isClientKey k = case k of { ClientKey {} -> True ; _ -> False }
+-}
 
 localJID :: Text -> Text -> Text -> IO Text
 localJID user "." resource = do
@@ -86,20 +88,21 @@ data ToxManager k = ToxManager
     }
 
 data PresenceState = forall status. PresenceState
-    { clients         :: TVar (Map ConnectionKey ClientState)
+    { clients         :: TVar (Map ClientAddress ClientState)
     , clientsByUser   :: TVar (Map Text LocalPresence)
     , clientsByProfile :: TVar (Map Text LocalPresence)
-    , remotesByPeer   :: TVar (Map ConnectionKey
+    , remotesByPeer   :: TVar (Map PeerAddress
                                    (Map UserName RemotePresence))
     , server          :: TMVar (XMPPServer, Connection.Manager status Text)
-    , keyToChan       :: TVar (Map ConnectionKey Conn)
+    , ckeyToChan       :: TVar (Map ClientAddress Conn)
+    , pkeyToChan       :: TVar (Map PeerAddress Conn)
     , consoleWriter   :: Maybe ConsoleWriter
-    , toxManager      :: Maybe (ToxManager ConnectionKey)
+    , toxManager      :: Maybe (ToxManager ClientAddress)
     }
 
 
 newPresenceState :: Maybe ConsoleWriter
-                 -> Maybe (PresenceState -> ToxManager ConnectionKey)
+                 -> Maybe (PresenceState -> ToxManager ClientAddress)
                  -> TMVar (XMPPServer, Connection.Manager status Text)
                  -> IO PresenceState
 newPresenceState cw toxman xmpp = atomically $ do
@@ -107,13 +110,15 @@ newPresenceState cw toxman xmpp = atomically $ do
         clientsByUser    <- newTVar Map.empty
         clientsByProfile <- newTVar Map.empty
         remotesByPeer    <- newTVar Map.empty
-        keyToChan        <- newTVar Map.empty
+        ckeyToChan       <- newTVar Map.empty
+        pkeyToChan       <- newTVar Map.empty
         let st = PresenceState
                     { clients          = clients
                     , clientsByUser    = clientsByUser
                     , clientsByProfile = clientsByProfile
                     , remotesByPeer    = remotesByPeer
-                    , keyToChan        = keyToChan
+                    , ckeyToChan       = ckeyToChan
+                    , pkeyToChan       = pkeyToChan
                     , server           = xmpp
                     , consoleWriter    = cw
                     , toxManager       = Nothing
@@ -121,7 +126,7 @@ newPresenceState cw toxman xmpp = atomically $ do
         return $ st { toxManager = fmap ($ st) toxman }
 
 
-nameForClient :: PresenceState -> ConnectionKey -> IO Text
+nameForClient :: PresenceState -> ClientAddress -> IO Text
 nameForClient state k = do
     mc <- atomically $ do
         cmap <- readTVar (clients state)
@@ -139,9 +144,8 @@ presenceHooks state verbosity mclient mpeer = XMPPServerParameters
     { xmppChooseResourceName        = chooseResourceName state
     , xmppTellClientHisName         = tellClientHisName state
     , xmppTellMyNameToClient        = nameForClient state
-    , xmppTellMyNameToPeer          = \addr -> return $ addrToText addr
+    , xmppTellMyNameToPeer          = \(Local addr) -> return $ addrToText addr
     , xmppTellPeerHisName           = return . peerKeyToText
-    , xmppTellClientNameOfPeer      = flip peerKeyToResolvedName
     , xmppNewConnection             = newConn state
     , xmppEOF                       = eofConn state
     , xmppRosterBuddies             = rosterGetBuddies state
@@ -164,7 +168,7 @@ presenceHooks state verbosity mclient mpeer = XMPPServerParameters
 
 
 data LocalPresence = LocalPresence
-    { networkClients :: Map ConnectionKey ClientState
+    { networkClients :: Map ClientAddress ClientState
     -- TODO: loginClients
     }
 
@@ -177,18 +181,17 @@ data RemotePresence = RemotePresence
 
 
 
-pcSingletonNetworkClient :: ConnectionKey
-                          -> ClientState -> LocalPresence
+pcSingletonNetworkClient :: ClientAddress -> ClientState -> LocalPresence
 pcSingletonNetworkClient key client =
     LocalPresence
     { networkClients = Map.singleton key client
     }
 
-pcInsertNetworkClient :: ConnectionKey -> ClientState -> LocalPresence -> LocalPresence
+pcInsertNetworkClient :: ClientAddress -> ClientState -> LocalPresence -> LocalPresence
 pcInsertNetworkClient key client pc =
     pc { networkClients = Map.insert key client (networkClients pc) }
 
-pcRemoveNewtworkClient :: ConnectionKey
+pcRemoveNewtworkClient :: ClientAddress
                         -> LocalPresence -> Maybe LocalPresence
 pcRemoveNewtworkClient key pc = if pcIsEmpty pc' then Nothing
                                                  else Just pc'
@@ -215,8 +218,8 @@ identifyTTY' ttypids uid inode = ttypid
        textify (tty,pid) = (fmap lazyByteStringToText tty, pid)
 
 chooseResourceName :: PresenceState
-                    -> ConnectionKey -> SockAddr -> Maybe Text -> Maybe Text -> IO Text
-chooseResourceName state k addr clientsNameForMe desired = do
+                    -> ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO Text
+chooseResourceName state k (Remote addr) clientsNameForMe desired = do
     muid <- getLocalPeerCred' addr
     (mtty,pid) <- getTTYandPID muid
     user <- getJabberUserForId muid
@@ -297,17 +300,17 @@ chooseResourceName state k addr clientsNameForMe desired = do
                         )
                    muid
 
--- Perform action with 'ClientState' associated with the given 'ConnectionKey'.
+-- Perform action with 'ClientState' associated with the given 'ClientAddress'.
 -- If there is no associated 'ClientState', then perform the supplied fallback
 -- action.
-forClient :: PresenceState -> ConnectionKey -> IO b -> (ClientState -> IO b) -> IO b
+forClient :: PresenceState -> 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 -> ConnectionKey -> IO Text
+tellClientHisName :: PresenceState -> ClientAddress -> IO Text
 tellClientHisName state k = forClient state k fallback go
  where
     fallback  = localJID "nobody" "." "fallback"
@@ -316,14 +319,14 @@ tellClientHisName state k = forClient state k fallback go
 toMapUnit :: Ord k => [k] -> Map k ()
 toMapUnit xs = Map.fromList $ map (,()) xs
 
-resolveAllPeers :: [Text] -> IO (Map SockAddr ())
+resolveAllPeers :: [Text] -> IO (Map PeerAddress ())
 resolveAllPeers hosts = fmap (toMapUnit . concat) $ Prelude.mapM (fmap (take 1) . resolvePeer) hosts
 
 
 -- Read a roster file and start trying to connect to all relevent peers.
 rosterGetStuff
   :: (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString])
-     -> PresenceState -> ConnectionKey -> IO [Text]
+     -> PresenceState -> ClientAddress -> IO [Text]
 rosterGetStuff what state k = forClient state k (return [])
     $ \client -> do
     jids <- configText what (clientUser client) (clientProfile client)
@@ -335,7 +338,7 @@ rosterGetStuff what state k = forClient state k (return [])
         -- Grok peers to associate with from the roster:
         forM_ hosts $ \host -> do
             -- We need either conns  :: Connection.Manager TCPStatus Text
-            --             or toxman :: ToxManager ConnectionKey
+            --             or toxman :: ToxManager ClientAddress
             -- It is decided by checking hostnames for .tox ending.
             let policySetter = fromMaybe (Connection.setPolicy conns host) $ do
                     toxman <- toxManager state
@@ -346,17 +349,17 @@ rosterGetStuff what state k = forClient state k (return [])
         atomically $ putTMVar svVar (sv,conns)
         return jids
 
-rosterGetBuddies :: PresenceState -> ConnectionKey -> IO [Text]
+rosterGetBuddies :: PresenceState -> ClientAddress -> IO [Text]
 rosterGetBuddies state k = rosterGetStuff ConfigFiles.getBuddies state k
 
-rosterGetSolicited :: PresenceState -> ConnectionKey -> IO [Text]
+rosterGetSolicited :: PresenceState -> ClientAddress -> IO [Text]
 rosterGetSolicited = rosterGetStuff ConfigFiles.getSolicited
 
 -- XXX: Should we be connecting to these peers?
-rosterGetOthers :: PresenceState -> ConnectionKey -> IO [Text]
+rosterGetOthers :: PresenceState -> ClientAddress -> IO [Text]
 rosterGetOthers = rosterGetStuff ConfigFiles.getOthers
 
-rosterGetSubscribers :: PresenceState -> ConnectionKey -> IO [Text]
+rosterGetSubscribers :: PresenceState -> ClientAddress -> IO [Text]
 rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers
 
 data Conn = Conn { connChan :: TChan Stanza
@@ -413,23 +416,20 @@ getBuddiesAndSolicited state pred
         -- of (Bool,Text) for processing outside.
         return (isbud,u,user,profile)
 
-sendProbesAndSolicitations :: PresenceState
-                            -> ConnectionKey -> SockAddr -> TChan Stanza -> IO ()
-sendProbesAndSolicitations state k laddr chan = do
+sendProbesAndSolicitations :: PresenceState -> PeerAddress -> Local SockAddr -> TChan Stanza -> IO ()
+sendProbesAndSolicitations state k (Local laddr) chan = do
     -- get all buddies & solicited matching k for all users
     xs <- getBuddiesAndSolicited state $ \case
         h | ".tox" `Text.isSuffixOf` h -> return False -- Tox probes/solicitations are handled in ToxToXMPP module.
         h -> do
             addrs <- nub `fmap` resolvePeer h
-            case k of
-                ClientKey _ -> return False            -- Solicitations and probes are only for peers.
-                PeerKey a   -> return $ a `elem` addrs -- Only for this peer /k/.
+            return $ k `elem` addrs -- Only for this peer /k/.
     forM_ xs $ \(isbud,u,user,profile) -> do
         let make = if isbud then presenceProbe
                             else presenceSolicitation
             toh = peerKeyToText k
             jid = unsplitJID (u,toh,Nothing)
-            me = addrToText laddr
+            me = addrToText laddr -- xmppTellMyNameToPeer
             from = if isbud then me -- probe from server
                             else -- solicitation from particular user
                                  unsplitJID (Just user,me,Nothing)
@@ -439,38 +439,35 @@ sendProbesAndSolicitations state k laddr chan = do
         atomically $ writeTChan chan stanza
     -- reverse xs `seq` return ()
 
-newConn :: PresenceState -> ConnectionKey -> ConnectionData -> TChan Stanza -> IO ()
-newConn state k cdta outchan = do
-    atomically $ modifyTVar' (keyToChan state)
-        $ Map.insert k Conn { connChan = outchan
-                            , auxData = cdta }
-    when (isPeerKey k)
-        $ sendProbesAndSolicitations state k (cdAddr cdta) outchan
+
+newConn :: PresenceState -> SockAddr -> ConnectionData -> TChan Stanza -> IO ()
+newConn state saddr cdta outchan =
+    case classifyConnection saddr cdta of
+        Left (pkey,laddr) -> do
+            atomically $ modifyTVar' (pkeyToChan state)
+                $ Map.insert pkey Conn { connChan = outchan
+                                       , auxData  = cdta }
+            sendProbesAndSolicitations state pkey laddr outchan
+        Right (ckey,_) -> do
+            atomically $ modifyTVar' (ckeyToChan state)
+                $ Map.insert ckey Conn { connChan = outchan
+                                       , auxData  = cdta }
 
 delclient :: (Alternative m, Monad m) =>
-           ConnectionKey -> m LocalPresence -> m LocalPresence
+           ClientAddress -> m LocalPresence -> m LocalPresence
 delclient k mlp = do
     lp <- mlp
     let nc = Map.delete k $ networkClients lp
     guard $ not (Map.null nc)
     return $ lp { networkClients = nc }
 
-eofConn :: PresenceState -> ConnectionKey -> IO ()
-eofConn state k = do
-    atomically $ modifyTVar' (keyToChan state) $ Map.delete k
-    case k of
-        ClientKey {} -> do
-            forClient state k (return ()) $ \client -> do
-            forM_ (toxManager state) $ \toxman -> do
-                case Text.splitAt 43 (clientProfile client) of
-                    (pub,".tox") -> deactivateAccount toxman k (clientProfile client)
-                    _            -> return ()
-            stanza <- makePresenceStanza "jabber:server" Nothing Offline
-            informClientPresence state k stanza
-            atomically $ do
-                modifyTVar' (clientsByUser    state) $ Map.alter (delclient k) (clientUser    client)
-                modifyTVar' (clientsByProfile state) $ Map.alter (delclient k) (clientProfile client)
-        PeerKey {} -> do
+eofConn :: PresenceState -> SockAddr -> ConnectionData -> IO ()
+eofConn state saddr cdta = do
+    atomically $ case classifyConnection saddr cdta of
+                    Left  (pkey,_) -> modifyTVar' (pkeyToChan state) $ Map.delete pkey
+                    Right (ckey,_) -> modifyTVar' (ckeyToChan state) $ Map.delete ckey
+    case classifyConnection saddr cdta of
+        Left (k,_) -> do
             let h = peerKeyToText k
             jids <- atomically $ do
                 rbp <- readTVar (remotesByPeer state)
@@ -482,29 +479,26 @@ eofConn state k = do
             forM_ jids $ \jid -> do
             stanza <- makePresenceStanza "jabber:client" (Just jid) Offline
             informPeerPresence state k stanza
+        Right (k,_) -> do
+            forClient state k (return ()) $ \client -> do
+            forM_ (toxManager state) $ \toxman -> do
+                case Text.splitAt 43 (clientProfile client) of
+                    (pub,".tox") -> deactivateAccount toxman k (clientProfile client)
+                    _            -> return ()
+            stanza <- makePresenceStanza "jabber:server" Nothing Offline
+            informClientPresence state k stanza
+            atomically $ do
+                modifyTVar' (clientsByUser    state) $ Map.alter (delclient k) (clientUser    client)
+                modifyTVar' (clientsByProfile state) $ Map.alter (delclient k) (clientProfile client)
 
--- | The given address is taken to be the local address for the socket this JID
--- came in on.  The returned JID parts are suitable for unsplitJID to create a
--- valid JID for communicating to a client.  The returned Bool is True when the
--- 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 :: SockAddr -> Text -> [Text] -> IO (Bool,(Maybe Text,Text,Maybe Text))
-rewriteJIDForClient laddr jid buds = do
-    let (n,h,r) = splitJID jid
-    maddr <- parseAddress (strip_brackets h)
-    fromMaybe (return (False,(n,ip6literal h,r))) $ maddr <&> \addr -> do
-    let mine =  laddr `withPort` 0  == addr `withPort` 0
-    h' <- if mine then textHostName
-                  else peerKeyToResolvedName buds (PeerKey addr)
-    return (mine,(n,h',r))
+parseRemoteAddress :: Text -> IO (Maybe (Remote SockAddr))
+parseRemoteAddress s = fmap Remote <$> parseAddress s
 
 -- This attempts to reverse resolve a peers address to give the human-friendly
 -- 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] -> ConnectionKey -> IO Text
-peerKeyToResolvedName buds k@(ClientKey { localAddress=addr }) = return "ErrorClIeNt1"
+peerKeyToResolvedName :: [Text] -> PeerAddress -> IO Text
 peerKeyToResolvedName buds pk = do
     ns <- peerKeyToResolvedNames pk
     let hs = map (\jid -> let (_,h,_)=splitJID jid in h) buds
@@ -512,27 +506,39 @@ peerKeyToResolvedName buds pk = do
     return $ fromMaybe (peerKeyToText pk) (listToMaybe ns')
 
 
+-- | The given address is taken to be the local address for the socket this JID
+-- came in on.  The returned JID parts are suitable for unsplitJID to create a
+-- valid JID for communicating to a client.  The returned Bool is True when the
+-- 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
+    let (n,h,r) = splitJID jid
+    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)
+    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 :: SockAddr -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)])
-multiplyJIDForClient laddr jid = do
+multiplyJIDForClient :: ClientAddress -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)])
+multiplyJIDForClient k jid = do
     let (n,h,r) = splitJID jid
     maddr <- parseAddress (strip_brackets h)
-    fromMaybe (return (False,[(n,ip6literal h,r)])) $ maddr <&> \addr -> do
-    let mine =  sameAddress laddr addr
+    fromMaybe (return (False,[(n,ip6literal h,r)])) $ maddr <&> \saddr -> do
+    let Local laddr = addrFromClientKey k
+        mine        = sameAddress laddr saddr
     names <- if mine then fmap (:[]) textHostName
-                     else peerKeyToResolvedNames (PeerKey addr)
+                     else peerKeyToResolvedNames (addrToPeerKey $ Remote saddr)
     return (mine,map (\h' -> (n,h',r)) names)
 
 
-addrTextToKey :: Text -> IO (Maybe ConnectionKey)
-addrTextToKey h = do
-    maddr <- parseAddress (strip_brackets h)
-    return (fmap PeerKey maddr)
-
-guardPortStrippedAddress :: Text -> SockAddr -> IO (Maybe ())
-guardPortStrippedAddress h laddr = do
+guardPortStrippedAddress :: Text -> Local SockAddr -> IO (Maybe ())
+guardPortStrippedAddress h (Local laddr) = do
     maddr <- fmap (fmap (`withPort` 0)) $ parseAddress (strip_brackets h)
     let laddr' = laddr `withPort` 0
     return $ maddr >>= guard . (==laddr')
@@ -541,15 +547,15 @@ guardPortStrippedAddress h laddr = do
 -- | Accepts a textual representation of a domainname
 -- JID suitable for client connections, and returns the
 -- coresponding ipv6 address JID suitable for peers paired
--- with a SockAddr with the address part of that JID in
+-- 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,SockAddr))
+rewriteJIDForPeer :: Text -> IO (Maybe (Text,PeerAddress))
 rewriteJIDForPeer jid = do
     let (n,h,r) = splitJID jid
     maddr <- fmap listToMaybe $ resolvePeer h
     return $ flip fmap maddr $ \addr ->
-        let h' = addrToText addr
+        let h' = peerKeyToText addr
             to' = unsplitJID (n,h',r)
         in (to',addr)
 
@@ -567,14 +573,15 @@ deliverMessage :: PresenceState
                 -> IO ()
 deliverMessage state fail msg =
     case stanzaOrigin msg of
-      NetworkOrigin senderk@(ClientKey {}) _ -> do
+      ClientOrigin senderk _ -> do
         -- Case 1.  Client -> Peer
         mto <- fmap join $ mapM rewriteJIDForPeer (stanzaTo msg)
-        fromMaybe fail {- reverse lookup failure -} $ mto <&> \(to',addr) -> do
-        let k = PeerKey addr
-        chans <- atomically $ readTVar (keyToChan state)
-        fromMaybe fail $ (Map.lookup k chans) <&> \(Conn { connChan = chan
-                                                        , auxData = ConnectionData laddr ctyp }) -> do
+        fromMaybe fail {- reverse lookup failure -} $ mto <&> \(to',k) -> do
+        chans <- atomically $ readTVar (pkeyToChan state)
+        fromMaybe fail $ (Map.lookup k chans) <&> \Conn { connChan = chan
+                                                        , auxData = ConnectionData (Left (Local laddr))
+                                                                                   ctyp
+                                                        } -> do
         (n,r) <- forClient state senderk (return (Nothing,Nothing))
                         $ \c -> return (Just (clientUser c), Just (clientResource c))
         -- original 'from' address is discarded.
@@ -582,11 +589,14 @@ deliverMessage state fail msg =
         -- dup <- atomically $ cloneStanza (msg { stanzaTo=Just to', stanzaFrom=Just from' })
         let dup = (msg { stanzaTo=Just to', stanzaFrom=Just from' })
         sendModifiedStanzaToPeer dup chan
-      NetworkOrigin senderk@(PeerKey {}) _ -> do
-        key_to_chan <- atomically $ readTVar (keyToChan state)
-        fromMaybe fail $ (Map.lookup senderk key_to_chan)
+      PeerOrigin senderk _ -> do
+        (pchans,cchans) <- atomically $ do
+            pc <- readTVar (pkeyToChan state)
+            cc <- readTVar (ckeyToChan state)
+            return (pc,cc)
+        fromMaybe fail $ (Map.lookup senderk pchans)
             <&> \(Conn { connChan = sender_chan
-                       , auxData  = ConnectionData laddr ctyp }) -> do
+                       , auxData  = ConnectionData (Left laddr) ctyp }) -> do
         fromMaybe fail $ (stanzaTo msg) <&> \to -> do
         (mine,(n,h,r)) <- rewriteJIDForClient laddr to []
         if not mine then fail else do
@@ -600,7 +610,7 @@ deliverMessage state fail msg =
             let ks = Map.keys (networkClients presence_container)
                 chans = do
                     (k,client) <- Map.toList $ networkClients presence_container
-                    chan <- maybeToList $ Map.lookup k key_to_chan
+                    chan <- maybeToList $ Map.lookup k cchans
                     return (clientProfile client, clientUser client, chan)
             forM chans $ \(profile,user,chan) -> do
             buds <- configText ConfigFiles.getBuddies user profile
@@ -642,7 +652,7 @@ deliverMessage state fail msg =
                                       chan
 
 
-setClientFlag :: PresenceState -> ConnectionKey -> Int8 -> IO ()
+setClientFlag :: PresenceState -> ClientAddress -> Int8 -> IO ()
 setClientFlag state k flag =
     atomically $ do
         cmap <- readTVar (clients state)
@@ -653,12 +663,12 @@ setClientFlag0 :: ClientState -> Int8 -> STM ()
 setClientFlag0 client flag =
     modifyTVar' (clientFlags client) (\flgs -> flgs .|. flag)
 
-informSentRoster :: PresenceState -> ConnectionKey -> IO ()
+informSentRoster :: PresenceState -> ClientAddress -> IO ()
 informSentRoster state k = do
     setClientFlag state k cf_interested
 
 
-subscribedPeers :: Text -> Text -> IO [SockAddr]
+subscribedPeers :: Text -> Text -> IO [PeerAddress]
 subscribedPeers user profile = do
     jids <- configText ConfigFiles.getSubscribers user profile
     let hosts = map ((\(_,h,_)->h) . splitJID) jids
@@ -667,20 +677,23 @@ subscribedPeers user profile = do
 -- | this JID is suitable for peers, not clients.
 clientJID :: Conn -> ClientState -> Text
 clientJID con client = unsplitJID ( Just $ clientUser client
-                                  , addrToText $ cdAddr $ auxData con
+                                  , either (\(Local a) -> addrToText a) -- my host name, for peers
+                                           (error $ unlines [ "clientJID wrongly used for client connection!"
+                                                            , "TODO: my host name for clients? nameForClient? localJID?"])
+                                           $ cdAddr $ auxData con
                                   , Just $ clientResource 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
-                        -> ConnectionKey -> StanzaWrap (LockedChan Event) -> IO ()
+                        -> ClientAddress -> StanzaWrap (LockedChan Event) -> IO ()
 informClientPresence state k stanza = do
     forClient state k (return ()) $ \client -> do
     informClientPresence0 state (Just k) client stanza
 
 informClientPresence0 :: PresenceState
-                       -> Maybe ConnectionKey
+                       -> Maybe ClientAddress
                        -> ClientState
                        -> StanzaWrap (LockedChan Event)
                        -> IO ()
@@ -692,8 +705,8 @@ informClientPresence0 state mbk client stanza = do
         atomically $ setClientFlag0 client cf_available
         maybe (return ()) (sendCachedPresence state) mbk
     addrs <- subscribedPeers (clientUser client) (clientProfile client)
-    ktc <- atomically $ readTVar (keyToChan state)
-    let connected = mapMaybe (flip Map.lookup ktc . PeerKey) addrs
+    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
@@ -706,7 +719,7 @@ informClientPresence0 state mbk client stanza = do
                              (connChan con)
 
 informPeerPresence :: PresenceState
-                    -> ConnectionKey
+                    -> PeerAddress
                     -> StanzaWrap (LockedChan Event)
                     -> IO ()
 informPeerPresence state k stanza = do
@@ -749,7 +762,7 @@ informPeerPresence state k stanza = do
 
         -- all clients, we'll filter available/authorized later
 
-        ktc <- readTVar (keyToChan state)
+        ktc <- readTVar (ckeyToChan state)
         runTraversableT $ do
         (ck,client) <- liftMT $ fmap Map.toList $ readTVar (clients state)
         con <- liftMaybe $ Map.lookup ck ktc
@@ -762,8 +775,7 @@ informPeerPresence state k stanza = do
         when is_avail $ do
         putStrLn $ "reversing for client: " ++ show from
         froms <- do -- flip (maybe $ return [from]) k . const $ do
-            let ClientKey laddr = ck
-            (_,trip) <- multiplyJIDForClient laddr from
+            (_,trip) <- multiplyJIDForClient ck from
             return (map unsplitJID trip)
 
         putStrLn $ "sending to client: " ++ show (stanzaType stanza,froms)
@@ -777,35 +789,37 @@ consoleClients PresenceState{ consoleWriter = Just cw } = readTVar (cwClients cw
 consoleClients _                                        = return Map.empty
 
 
-answerProbe :: PresenceState
-             -> Maybe Text -> ConnectionKey -> TChan Stanza -> IO ()
+answerProbe :: PresenceState -> Maybe Text -> PeerAddress -> TChan Stanza -> IO ()
 answerProbe state mto k chan = do
     -- putStrLn $ "answerProbe! " ++ show (stanzaType stanza)
-    (ktc,cmap) <- atomically $ (,) <$> readTVar (keyToChan state)
-                                   <*> readTVar (clients state)
+    ktc <- atomically $ readTVar (pkeyToChan state)
     muser <- runTraversableT $ do
         to <- liftT $ mto
         conn <- liftT $ Map.lookup k ktc
         let (mu,h,_) = splitJID to -- TODO: currently resource-id is ignored on presence
                                    --  probes.  Is this correct? Check the spec.
-        liftMT $ guardPortStrippedAddress h (cdAddr $ auxData conn)
+            Left laddr = cdAddr $ auxData conn
+        liftMT $ guardPortStrippedAddress h laddr
         u <- liftT mu
-        let ch      = addrToText (cdAddr $ auxData conn)
-            profile = fromMaybe "." $ clientProfile <$> Map.lookup k cmap
-        return (u,profile,conn,ch)
+        -- ORIG let ch = addrToText (auxAddr conn)
+        -- ORIG return (u,conn,ch)
+        let ch      = addrToText a where Local a = laddr
+        return (u,conn,ch)
 
-    forM_ muser $ \(u,profile,conn,ch) -> do
+    forM_ muser $ \(u,conn,ch) -> do
 
+    profiles <- releventProfiles (cdType $ auxData conn) u
+    forM_ profiles $ \profile -> do
+
+    -- only subscribed peers should get probe replies
     resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u profile
-    let gaddrs = groupBy (\a b -> snd a == snd b) (sort resolved_subs)
+    let gaddrs = groupBy sameHost (sort resolved_subs)
+        sameHost a b = (snd a == snd b) -- (==) `on` snd
         whitelist = do
-            xs <- gaddrs
-            x <- take 1 xs
-            guard $ snd x==k
-            mapMaybe fst xs
-
-    -- -- only subscribed peers should get probe replies
-    -- addrs <- subscribedPeers u
+            xs <- gaddrs     -- group of subscribed jids on the same host
+            x <- take 1 xs   -- the host from the group
+            guard $ snd x==k -- only hosts matching the key /k/
+            mapMaybe fst xs  -- all users subscribed at the remote peer /k/
 
     -- TODO: notify remote peer that they are unsubscribed?
     --   reply <- makeInformSubscription "jabber:server" to from False
@@ -838,16 +852,15 @@ answerProbe state mto k chan = do
 
 -- Send friend requests and remote presences stored in remotesByPeer to XMPP
 -- clients.
-sendCachedPresence :: PresenceState -> ConnectionKey -> IO ()
+sendCachedPresence :: PresenceState -> 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
-    let onlines = rbp `Map.intersection` Map.mapKeys PeerKey addrs
-        ClientKey laddr = k
-    mcon <- atomically $ do ktc <- readTVar (keyToChan state)
+    let onlines = rbp `Map.intersection` addrs
+    mcon <- atomically $ do ktc <- readTVar (ckeyToChan state)
                             return $ Map.lookup k ktc
     forM_ mcon $ \con -> do
     forM_ (Map.toList onlines) $ \(pk, umap) -> do
@@ -855,7 +868,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 laddr jid
+        (mine,js) <- multiplyJIDForClient k jid
         forM_ js $ \jid -> do
         let from' = unsplitJID jid
         dup <- cloneStanza stanza
@@ -883,7 +896,7 @@ addToRosterFile ::
                   -> t1)
                  -> Text -- user
                  -> Text -- profile
-                 -> Text -> [SockAddr] -> t1
+                 -> Text -> [PeerAddress] -> t1
 addToRosterFile doit whose profile to addrs =
     modifyRosterFile doit whose profile to addrs True
 
@@ -895,7 +908,7 @@ removeFromRosterFile ::
                        -> t1)
                       -> Text -- user
                       -> Text -- profile
-                      -> Text -> [SockAddr] -> t1
+                      -> Text -> [PeerAddress] -> t1
 removeFromRosterFile doit whose profile to addrs =
     modifyRosterFile doit whose profile to addrs False
 
@@ -920,7 +933,7 @@ modifyRosterFile ::
                   -> Text       -- ^ user
                   -> Text       -- ^ profile
                   -> Text       -- ^ JID that will be added or removed a hostname
-                  -> [SockAddr] -- ^ Alias addresses for hostname in the JID.
+                  -> [PeerAddress] -- ^ Alias addresses for hostname in the JID.
                   -> Bool       -- ^ True if adding, otherwise False
                   -> t1
 modifyRosterFile doit whose profile to addrs bAdd = do
@@ -951,7 +964,7 @@ modifyRosterFile doit whose profile to addrs bAdd = do
          (guard bAdd >> Just (textToLazyByteString to))
 
 
-clientSubscriptionRequest :: PresenceState -> IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO ()
+clientSubscriptionRequest :: PresenceState -> 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
@@ -967,7 +980,7 @@ clientSubscriptionRequest state fail k stanza chan = do
     addToRosterFile      ConfigFiles.modifySolicited cuser cprof to addrs
     removeFromRosterFile ConfigFiles.modifyBuddies   cuser cprof to addrs
     resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers cuser cprof
-    let is_subscribed = not . null $ [ (mu, PeerKey a) | a <- addrs ]
+    let is_subscribed = not . null $ [ (mu, a) | a <- addrs ]
                                      `intersect` resolved_subs
     -- subscribers: "from"
     -- buddies: "to"
@@ -975,16 +988,18 @@ clientSubscriptionRequest state fail k stanza chan = do
     case state of
       PresenceState { server = svVar } -> do
 
-        (ktc,(sv,conns)) <- atomically $
-            liftM2 (,) (readTVar $ keyToChan state)
-                       (takeTMVar svVar)
+        (cktc,pktc,(sv,conns)) <- atomically $ do
+            cktc <- readTVar $ ckeyToChan state
+            pktc <- readTVar $ pkeyToChan state
+            sc <- takeTMVar svVar
+            return (cktc,pktc,sc)
 
         -- Update roster for each client.
         case stanzaType stanza of
          PresenceRequestSubscription True -> do
             hostname <- nameForClient state k
             let cjid = unsplitJID (Just $ clientUser client, hostname,Nothing)
-            chans <- clientCons state ktc (clientUser client)
+            chans <- clientCons state cktc (clientUser client)
             forM_ chans $ \( Conn { connChan=chan }, client ) -> do
                 -- roster update ask="subscribe"
                 update <- makeRosterUpdate cjid to
@@ -996,13 +1011,13 @@ clientSubscriptionRequest state fail k stanza chan = do
          _ -> return ()
 
         -- Send friend request to peer.
-        let dsts = ktc `Map.intersection`
-                        Map.fromList [ (PeerKey a, ()) | a <- addrs ]
+        let dsts = pktc `Map.intersection` toMapUnit addrs
         forM_ (Map.toList dsts) $ \(pk,con) -> do
             -- if already connected, send solicitation ...
             -- let from = clientJID con client
-            let from = unsplitJID ( Just $ clientUser client
-                                  , addrToText $ cdAddr $ auxData con
+            let Left laddr = cdAddr $ auxData con
+                from = unsplitJID ( Just $ clientUser client
+                                  , (\(Local a) -> addrToText a) $ laddr
                                   , Nothing )
             mb <- rewriteJIDForPeer to
             forM_ mb $ \(to',addr) -> do
@@ -1022,20 +1037,20 @@ clientSubscriptionRequest state fail k stanza chan = do
 
 resolvedFromRoster
   :: (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString])
-     -> UserName -> Text -> IO [(Maybe UserName, ConnectionKey)]
+     -> UserName -> Text -> IO [(Maybe UserName, PeerAddress)]
 resolvedFromRoster doit u profile = do
     subs <- configText doit u profile
     runTraversableT $ do
             (mu,h,_) <- liftT $ splitJID `fmap` subs
             addr <- liftMT $ fmap nub $ resolvePeer h
-            return (mu,PeerKey addr)
+            return (mu,addr)
 
 clientCons :: PresenceState
-            -> Map ConnectionKey t -> Text -> IO [(t, ClientState)]
+            -> Map ClientAddress t -> Text -> IO [(t, ClientState)]
 clientCons state ktc u = map snd <$> clientCons' state ktc u
 
 clientCons' :: PresenceState
-            -> Map ConnectionKey t -> Text -> IO [(ConnectionKey,(t, ClientState))]
+            -> Map ClientAddress t -> Text -> IO [(ClientAddress,(t, ClientState))]
 clientCons' state ktc u = do
     mlp <- atomically $ do
             cmap <- readTVar $ clientsByUser state
@@ -1047,7 +1062,14 @@ clientCons' state ktc u = do
             return (k,(con,client))
     return $ mapMaybe doit ks
 
-peerSubscriptionRequest :: PresenceState -> IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO ()
+releventProfiles :: ConnectionType -> Text -> IO [Text]
+releventProfiles XMPP _    = return ["."]
+releventProfiles ctyp user = do
+    -- TODO: Return all the ".tox" profiles that a user has under his
+    -- .presence/ directory.
+    return []
+
+peerSubscriptionRequest :: PresenceState -> IO () -> PeerAddress -> Stanza -> TChan Stanza -> IO ()
 peerSubscriptionRequest state fail k stanza chan = do
     putStrLn $ "Handling pending subscription from remote"
     fromMaybe fail $ (stanzaFrom stanza) <&> \from -> do
@@ -1056,24 +1078,20 @@ peerSubscriptionRequest state fail k stanza chan = do
         (mfrom_u,from_h,_) = splitJID from
     to <- return $ unsplitJID (mto_u,h,Nothing) -- delete resource
     from <- return $ unsplitJID (mfrom_u,from_h,Nothing) -- delete resource
-    (ktc,cmap) <- atomically $ (,) <$> readTVar (keyToChan state)
-                                   <*> readTVar (clients state)
-    fromMaybe fail $ (Map.lookup k ktc)
-        <&> \Conn { auxData=ConnectionData laddr ctyp } -> do
+    (pktc,cktc,cmap) <- atomically $ do
+        cktc <- readTVar (ckeyToChan state)
+        pktc <- readTVar (pkeyToChan state)
+        cmap <- readTVar (clients state)
+        return (pktc,cktc,cmap)
+    fromMaybe fail $ (Map.lookup k pktc)
+        <&> \Conn { auxData=ConnectionData (Left laddr) ctyp } -> do
     (mine,totup) <- rewriteJIDForClient laddr to []
     if not mine then fail else do
     (_,fromtup) <- rewriteJIDForClient laddr from []
     fromMaybe fail $ mto_u <&> \u -> do
     fromMaybe fail $ mfrom_u <&> \from_u -> do
-    let profile = fromMaybe "." $ clientProfile <$> Map.lookup k cmap
-    -- XXX profile is wrong.
-    -- TODO Likely the problem is that k is a peer ConnectionKey and of course
-    --      will have no entry in the cmap.  Thus giving "." even though it ought
-    --      to be using a tox profile.
-    --
-    -- Solution 1: Only .tox peers go in a tox profile.
-    -- Solution 2: Duplicate non .tox peers in all profiles.
-    -- Solution 3: Only one profile is active at a time.
+    profiles <- releventProfiles ctyp u
+    forM_ profiles $ \profile -> do
     resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u profile
     let already_subscribed = elem (mfrom_u,k) resolved_subs
         is_wanted = case stanzaType stanza of
@@ -1116,7 +1134,7 @@ peerSubscriptionRequest state fail k stanza chan = do
     when (not already_pending) $ do
     -- contact ∉ subscribers & contact ∉ pending --> MUST
 
-    chans <- clientCons state ktc u
+    chans <- clientCons state cktc u
     forM_ chans $ \( Conn { connChan=chan }, client ) -> do
     -- send to clients
     -- TODO: interested/available clients only?
@@ -1128,7 +1146,7 @@ peerSubscriptionRequest state fail k stanza chan = do
 
 clientInformSubscription :: PresenceState
                           -> IO ()
-                          -> ConnectionKey
+                          -> ClientAddress
                           -> StanzaWrap (LockedChan Event)
                           -> IO ()
 clientInformSubscription state fail k stanza = do
@@ -1139,7 +1157,7 @@ clientInformSubscription state fail k stanza = do
     addrs <- resolvePeer h
     -- remove from pending
     buds <- resolvedFromRoster ConfigFiles.getBuddies (clientUser client) (clientProfile client)
-    let is_buddy = not . null $ map ((mu,) . PeerKey) addrs `intersect` buds
+    let is_buddy = not . null $ map (mu,) addrs `intersect` buds
     removeFromRosterFile ConfigFiles.modifyPending (clientUser client) (clientProfile client) to addrs
     let (relationship,addf,remf) =
          case stanzaType stanza of
@@ -1160,12 +1178,13 @@ clientInformSubscription state fail k stanza = do
         putStrLn $ "cbu = " ++ show (fmap (fmap clientPid . networkClients) cbu)
 
     -- send roster update to clients
-    (clients,ktc) <- atomically $ do
+    (clients,ktc,pktc) <- atomically $ do
         cbu <- readTVar (clientsByUser state)
         let mlp = Map.lookup (clientUser client) cbu
         let cs = maybe [] (Map.toList . networkClients) mlp
-        ktc <- readTVar (keyToChan state)
-        return (cs,ktc)
+        ktc <- readTVar (ckeyToChan state)
+        pktc <- readTVar (pkeyToChan state)
+        return (cs,ktc,pktc)
     forM_ clients $ \(ck, client) -> do
         is_intereseted <- atomically $ clientIsInterested client
         putStrLn $ "clientIsInterested: "++show is_intereseted
@@ -1179,8 +1198,8 @@ clientInformSubscription state fail k stanza = do
         sendModifiedStanzaToClient update (connChan con)
 
     -- notify peer
-    let dsts = Map.fromList $ map ((,()) . PeerKey) addrs
-        cdsts = ktc `Map.intersection` dsts
+    let dsts = toMapUnit addrs
+        cdsts = pktc `Map.intersection` dsts
     forM_ (Map.toList cdsts) $ \(pk,con) -> do
         let from = clientJID con client
             to' = unsplitJID (mu, peerKeyToText pk, Nothing)
@@ -1192,18 +1211,21 @@ clientInformSubscription state fail k stanza = do
 
 peerInformSubscription :: PresenceState
                         -> IO ()
-                        -> ConnectionKey
+                        -> PeerAddress
                         -> StanzaWrap (LockedChan Event)
                         -> IO ()
 peerInformSubscription state fail k stanza = do
     putStrLn $ "TODO: peerInformSubscription"
     -- remove from solicited
     fromMaybe fail $ (stanzaFrom stanza) <&> \from -> do
-    (ktc,cmap) <- atomically $ (,) <$> readTVar (keyToChan state)
-                                   <*> readTVar (clients state)
+    (ktc,cktc,cmap) <- atomically $ do
+        pktc <- readTVar (pkeyToChan state)
+        cktc <- readTVar (ckeyToChan state)
+        cmap <- readTVar (clients state)
+        return (pktc,cktc,cmap)
     fromMaybe fail $ (Map.lookup k ktc)
         <&> \(Conn { connChan=sender_chan
-                   , auxData =ConnectionData laddr ctyp }) -> do
+                   , auxData =ConnectionData (Left laddr) ctyp }) -> do
     (_,(from_u,from_h,_)) <- rewriteJIDForClient laddr from []
     let from'' = unsplitJID (from_u,from_h,Nothing)
         muser = do
@@ -1215,10 +1237,11 @@ 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
-    let profile = fromMaybe "." $ clientProfile <$> Map.lookup k cmap
+    profiles <- releventProfiles ctyp user
+    forM_ profiles $ \profile -> do
     was_solicited <- removeFromRosterFile ConfigFiles.modifySolicited user profile from'' addrs
     subs <- resolvedFromRoster ConfigFiles.getSubscribers user profile
-    let is_sub = not . null $ map ((from_u,) . PeerKey) addrs `intersect` subs
+    let is_sub = not . null $ map (from_u,) addrs `intersect` subs
     putStrLn $ "DEBUG peerInformSubscription (is_sub,typ)=" ++ show (is_sub,stanzaType stanza)
     let (relationship,addf,remf) =
          case stanzaType stanza of
@@ -1234,7 +1257,7 @@ peerInformSubscription state fail k stanza = do
     addToRosterFile      addf user profile from'' addrs
     removeFromRosterFile remf user profile from'' addrs
 
-    chans <- clientCons' state ktc user
+    chans <- clientCons' state cktc user
     forM_ chans $ \(ckey,(Conn { connChan=chan }, client)) -> do
     hostname <- nameForClient state ckey
     let to' = unsplitJID (Just user, hostname, Nothing)
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 8d294698..1de6a26a 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -7,11 +7,17 @@
 module XMPPServer
     ( xmppServer
     , quitXmpp
-    , ConnectionKey(..)
+    , ClientAddress
+    , PeerAddress
+    , Local(..)
+    , Remote(..)
     , ConnectionData(..)
     , ConnectionType(..)
     , XMPPServerParameters(..)
     , XMPPServer
+    , classifyConnection
+    , addrToPeerKey
+    , addrFromClientKey
     , xmppConnections
     , xmppEventChannel
     , StanzaWrap(..)
@@ -85,7 +91,7 @@ import Data.XML.Types as XML
 import Data.Maybe
 import Data.Monoid ( (<>) )
 import Data.Text (Text)
-import qualified Data.Text as Text (pack,unpack,words,intercalate)
+import qualified Data.Text as Text (pack,unpack,words,intercalate,drop)
 import Data.Char (chr,ord)
 import qualified Data.Map as Map
 import Data.Set (Set, (\\) )
@@ -167,7 +173,10 @@ data StanzaType
     | InternalCacheId Text
  deriving (Show,Eq)
 
-data StanzaOrigin = LocalPeer | NetworkOrigin ConnectionKey (TChan Stanza)
+data StanzaOrigin = LocalPeer
+                  | PeerOrigin PeerAddress (TChan Stanza)
+                  | ClientOrigin ClientAddress (TChan Stanza)
+
 
 data StanzaWrap a = Stanza
     { stanzaType :: StanzaType
@@ -182,6 +191,9 @@ data StanzaWrap a = Stanza
 
 type Stanza = StanzaWrap (LockedChan XML.Event)
 
+newtype Local a = Local a deriving (Eq,Ord,Show)
+newtype Remote a = Remote a deriving (Eq,Ord,Show)
+
 data XMPPServerParameters =
     XMPPServerParameters
     { -- | Called when a client requests a resource id.  The first Maybe indicates
@@ -190,36 +202,35 @@ data XMPPServerParameters =
       --
       -- Note: The returned domain will be discarded and replaced with the result of
       -- 'xmppTellMyNameToClient'.
-      xmppChooseResourceName :: ConnectionKey -> SockAddr -> Maybe Text -> Maybe Text -> IO Text
+      xmppChooseResourceName :: ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO Text
     , -- | This should indicate the server's hostname that all client's see.
-      xmppTellMyNameToClient :: ConnectionKey -> IO Text
-    , xmppTellMyNameToPeer   :: SockAddr -> IO Text
-    , xmppTellClientHisName  :: ConnectionKey -> IO Text
-    , xmppTellPeerHisName    :: ConnectionKey -> IO Text
-    , xmppNewConnection      :: ConnectionKey -> ConnectionData -> TChan Stanza -> IO ()
-    , xmppEOF                :: ConnectionKey -> IO ()
-    , xmppRosterBuddies      :: ConnectionKey -> IO [Text]
-    , xmppRosterSubscribers  :: ConnectionKey -> IO [Text]
-    , xmppRosterSolicited    :: ConnectionKey -> IO [Text]
-    , xmppRosterOthers       :: ConnectionKey -> IO [Text]
+      xmppTellMyNameToClient :: ClientAddress -> IO Text
+    , xmppTellMyNameToPeer   :: Local SockAddr -> IO Text
+    , xmppTellClientHisName  :: ClientAddress -> IO Text
+    , xmppTellPeerHisName    :: PeerAddress -> IO Text
+    , xmppNewConnection      :: SockAddr -> ConnectionData -> TChan Stanza -> IO ()
+    , xmppEOF                :: SockAddr -> ConnectionData -> IO ()
+    , xmppRosterBuddies      :: ClientAddress -> IO [Text]
+    , xmppRosterSubscribers  :: ClientAddress -> IO [Text]
+    , xmppRosterSolicited    :: ClientAddress -> IO [Text]
+    , xmppRosterOthers       :: ClientAddress -> IO [Text]
     , -- | Called when after sending a roster to a client.  Usually this  means
       -- the client status should change from "available" to "interested".
-      xmppSubscribeToRoster  :: ConnectionKey -> IO ()
-    -- , xmppLookupClientJID :: ConnectionKey -> IO Text
-    , xmppTellClientNameOfPeer :: ConnectionKey -> [Text] -> IO Text
+      xmppSubscribeToRoster  :: ClientAddress -> IO ()
+    -- , xmppLookupClientJID :: SockAddr -> IO Text
     , xmppDeliverMessage     :: (IO ()) -> Stanza -> IO ()
       -- | Called whenever a local client's presence changes.
-    , xmppInformClientPresence :: ConnectionKey -> Stanza -> IO ()
+    , xmppInformClientPresence :: ClientAddress -> Stanza -> IO ()
       -- | Called whenever a remote peer's presence changes.
-    , xmppInformPeerPresence :: ConnectionKey -> Stanza -> IO ()
+    , xmppInformPeerPresence :: PeerAddress -> Stanza -> IO ()
     , -- | Called when a remote peer requests our status.
-      xmppAnswerProbe        :: ConnectionKey -> Stanza -> TChan Stanza -> IO ()
-    , xmppClientSubscriptionRequest :: IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO ()
+      xmppAnswerProbe        :: PeerAddress -> Stanza -> TChan Stanza -> IO ()
+    , xmppClientSubscriptionRequest :: IO () -> ClientAddress -> Stanza -> TChan Stanza -> IO ()
     , -- | Called when a remote peer sends subscription request.
-      xmppPeerSubscriptionRequest :: IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO ()
-    , xmppClientInformSubscription :: IO () -> ConnectionKey -> Stanza -> IO ()
+      xmppPeerSubscriptionRequest :: IO () -> PeerAddress -> Stanza -> TChan Stanza -> IO ()
+    , xmppClientInformSubscription :: IO () -> ClientAddress -> Stanza -> IO ()
     , -- | Called when a remote peer informs us of our subscription status.
-      xmppPeerInformSubscription :: IO () -> ConnectionKey -> Stanza -> IO ()
+      xmppPeerInformSubscription :: IO () -> PeerAddress -> Stanza -> IO ()
     , xmppVerbosity          :: IO Int
     , xmppClientBind         :: Maybe SockAddr
     , xmppPeerBind           :: Maybe SockAddr
@@ -270,10 +281,9 @@ addrToText (addr@(SockAddrInet6 _ _ _ _)) = Text.pack $ stripColon (show addr)
           where
             (pre,bracket) = break (==']') s
 
--- Shows (as Text) the IP address associated with the given ConnectionKey.
-peerKeyToText :: ConnectionKey -> Text
-peerKeyToText (PeerKey { callBackAddress=addr }) = addrToText addr
-peerKeyToText (ClientKey { localAddress=addr }) = "ErrorClIeNt0"
+-- Shows (as Text) the IP address associated with the given SockAddr.
+peerKeyToText :: PeerAddress -> Text
+peerKeyToText (PeerAddress addr) = addrToText addr
 
 
 wlog :: String -> IO ()
@@ -895,26 +905,17 @@ makePong namespace mid to from =
        , EventEndElement (mkname namespace "iq")
        ]
 
+data ClientOrPeer = IsClient | IsPeer
 
-xmppInbound :: Server ConnectionKey ConnectionData releaseKey XML.Event
-                -> XMPPServerParameters
-                -> ConnectionKey
-                -> SockAddr
-                -> FlagCommand  -- ^ action to check whether the connection needs a ping
+xmppInbound :: Server SockAddr ConnectionData releaseKey XML.Event -- ^ XXX: unused
+                -> XMPPServerParameters -- ^ XXX: unused
+                -> (Text, IO Text, IO Text, TChan Stanza -> StanzaOrigin)
+                -> FlagCommand  -- ^ action to check whether the connection needs a ping (XXX: unused)
                 -> TChan Stanza -- ^ channel to announce incoming stanzas on
                 -> TChan Stanza -- ^ channel used to send stanzas
                 -> TMVar ()     -- ^ mvar that is filled when the connection quits
-                -> Sink XML.Event IO ()
-xmppInbound sv xmpp k laddr pingflag stanzas output donevar = doNestingXML $ do
-    let (namespace,tellmyname,tellyourname) = case k of
-            ClientKey {} -> ( "jabber:client"
-                            , xmppTellMyNameToClient xmpp k
-                            , xmppTellClientHisName xmpp k
-                            )
-            PeerKey {} -> ( "jabber:server"
-                          , xmppTellMyNameToPeer xmpp laddr
-                          , xmppTellPeerHisName xmpp k
-                          )
+                -> ConduitM Event o IO ()
+xmppInbound sv xmpp (namespace,tellmyname,tellyourname,mkorigin) pingflag stanzas output donevar = doNestingXML $ do
     me <- liftIO tellmyname
     withXML $ \begindoc -> do
     when (begindoc==EventBeginDocument) $ do
@@ -948,7 +949,7 @@ xmppInbound sv xmpp k laddr pingflag stanzas output donevar = doNestingXML $ do
                               , stanzaChan = chan
                               , stanzaClosers = clsrs
                               , stanzaInterrupt = donevar
-                              , stanzaOrigin = NetworkOrigin k output
+                              , stanzaOrigin = mkorigin output
                               }
                 ioWriteChan stanzas s
           you <- liftIO tellyourname
@@ -973,7 +974,7 @@ xmppInbound sv xmpp k laddr pingflag stanzas output donevar = doNestingXML $ do
                             , stanzaChan = chan
                             , stanzaClosers = clsrs
                             , stanzaInterrupt = donevar
-                            , stanzaOrigin = NetworkOrigin k output
+                            , stanzaOrigin = mkorigin output
                             }
 #endif
               stype -> ioWriteChan stanzas Stanza
@@ -986,7 +987,7 @@ xmppInbound sv xmpp k laddr pingflag stanzas output donevar = doNestingXML $ do
                             , stanzaChan      = chan
                             , stanzaClosers   = clsrs
                             , stanzaInterrupt = donevar
-                            , stanzaOrigin    = NetworkOrigin k output
+                            , stanzaOrigin    = mkorigin output
                             }
           awaitCloser stanza_lvl
         liftIO . atomically $ writeTVar clsrs Nothing
@@ -1244,19 +1245,23 @@ slotsToSource slots nesting lastStanza needsFlush rdone =
                 ,readTMVar rdone >> return (return ())
                 ]
 
-forkConnection :: Server ConnectionKey ConnectionData releaseKey XML.Event
+forkConnection :: Server SockAddr ConnectionData releaseKey XML.Event
                 -> XMPPServerParameters
-                -> ConnectionKey
+                -> SockAddr -- SockAddr (remote for peer, local for client)
                 -> ConnectionData
                 -> FlagCommand
                 -> Source IO XML.Event
                 -> Sink (Flush XML.Event) IO ()
                 -> TChan Stanza
                 ->  IO (TChan Stanza)
-forkConnection sv xmpp k (ConnectionData laddr _) pingflag src snk stanzas = do
-    let (namespace,tellmyname) = case k of
-                        ClientKey {} -> ("jabber:client", xmppTellMyNameToClient xmpp k)
-                        PeerKey {} -> ("jabber:server",xmppTellMyNameToPeer xmpp laddr)
+forkConnection sv xmpp saddr (ConnectionData auxAddr _) pingflag src snk stanzas = do
+    let clientOrServer@(namespace,tellmyname,telltheirname,_) = case auxAddr of
+            Right _    -> ("jabber:client", xmppTellMyNameToClient xmpp (ClientAddress saddr)
+                                          , xmppTellClientHisName xmpp (ClientAddress saddr)
+                                          , ClientOrigin (ClientAddress saddr))
+            Left laddr -> ("jabber:server", xmppTellMyNameToPeer xmpp laddr
+                                          , xmppTellPeerHisName xmpp (PeerAddress saddr)
+                                          , PeerOrigin (PeerAddress saddr))
     me <- tellmyname
     rdone <- atomically newEmptyTMVar
     let isStarter (Left _) = True
@@ -1274,7 +1279,11 @@ forkConnection sv xmpp k (ConnectionData laddr _) pingflag src snk stanzas = do
             CL.sourceList (greet' namespace me) =$= CL.map Chunk
             yield Flush
         slot_src = slotsToSource slots nesting lastStanza needsFlush rdone
-    forkIO $ do myThreadId >>= flip labelThread ("post-queue."++show k)
+    let lbl n = concat [ n
+                       , Text.unpack (Text.drop 7 namespace)
+                       , "."
+                       , show saddr ]
+    forkIO $ do myThreadId >>= flip labelThread (lbl "post-queue.")
                 (greet_src >> slot_src) $$ snk
                 last <- atomically $ readTVar lastStanza
                 es <- while (atomically . fmap not $ Slotted.isEmpty slots)
@@ -1298,14 +1307,14 @@ forkConnection sv xmpp k (ConnectionData laddr _) pingflag src snk stanzas = do
                                     _ -> True
                 -- TODO: Probably some stanzas should be queued or saved for re-connect.
                 mapM_ fail $ filter notError (maybeToList last ++ es')
-                wlog $ "end post-queue fork: " ++ show k
+                wlog $ "end post-queue fork: " ++ (lbl "")
 
     output <- atomically newTChan
     hacks <- atomically $ newTVar Map.empty
     msgids <- atomically $ newTVar []
     forkIO $ do
         -- mapM_ (atomically . Slotted.push slots Nothing) greetPeer
-        myThreadId >>= flip labelThread ("pre-queue."++show k)
+        myThreadId >>= flip labelThread (lbl "pre-queue.")
         verbosity <- xmppVerbosity xmpp
         fix $ \loop -> do
             what <- atomically $ foldr1 orElse
@@ -1320,9 +1329,9 @@ forkConnection sv xmpp k (ConnectionData laddr _) pingflag src snk stanzas = do
                     notping $ do
                         dup <- cloneStanza stanza
                         let typ = Strict8.pack $ c ++ "<-"++(concat . take 1 . words $ show (stanzaType dup))++" "
-                            c = case k of
-                                    ClientKey {} -> "C"
-                                    PeerKey {}   -> "P"
+                            c = case auxAddr of
+                                    Right _ -> "C"
+                                    Left  _ -> "P"
                         wlog ""
                         stanzaToConduit dup $$ prettyPrint typ
                     -- wlog $ "hacks: "++show (stanzaId stanza)
@@ -1360,7 +1369,7 @@ forkConnection sv xmpp k (ConnectionData laddr _) pingflag src snk stanzas = do
                     loop
                 ,do pingflag >>= check
                     return $ do
-                    to <- xmppTellPeerHisName xmpp k -- addrToText (callBackAddress k)
+                    to <- telltheirname
                     let from = me -- Look it up from Server object
                                   -- or pass it with Connection event.
                         mid = Just "ping"
@@ -1368,23 +1377,21 @@ forkConnection sv xmpp k (ConnectionData laddr _) pingflag src snk stanzas = do
                     ping <- atomically $ wrapStanzaList ping0
                     mapM_ (atomically . Slotted.push slots (Just $ PingSlot))
                           ping
-#ifdef PINGNOISE
                     wlog ""
-                    CL.sourceList ping0 $$ prettyPrint $ case k of
-                        ClientKey {} -> "C<-Ping"
-                        PeerKey {} -> "P<-Ping "
-#endif
+                    CL.sourceList ping0 $$ prettyPrint $ case auxAddr of
+                        Right _ -> "C<-Ping"
+                        Left  _ -> "P<-Ping "
                     loop
                 ,readTMVar rdone >> return (return ())
                 ]
             what
-        wlog $ "end pre-queue fork: " ++ show k
+        wlog $ "end pre-queue fork: " ++ show (lbl "")
     forkIO $ do
-        myThreadId >>= flip labelThread ("reader."++show k)
+        myThreadId >>= flip labelThread (lbl "reader.")
         -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show)
-        src $$ xmppInbound sv xmpp k laddr pingflag stanzas output rdone
+        src $$ xmppInbound sv xmpp clientOrServer pingflag stanzas output rdone
         atomically $ putTMVar rdone ()
-        wlog $ "end reader fork: " ++ show k
+        wlog $ "end reader fork: " ++ lbl ""
     return output
 
 {-
@@ -1398,22 +1405,22 @@ data PeerState
     | PeerConnected (TChan Stanza)
 -}
 
-peerKey :: SocketLike sock => Maybe SockAddr -> sock -> IO (ConnectionKey,ConnectionData)
-peerKey outgoingPeerPort sock = do
-    addr <- getSocketName sock
-    peer <-
+peerKey :: SocketLike sock => Maybe SockAddr -> sock -> IO (SockAddr,ConnectionData)
+peerKey bind_addr sock = do
+    laddr <- getSocketName sock
+    raddr <-
       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),ConnectionData laddr XMPP)
+             else return laddr     -- Weird hack: addr is would-be peer name
+    -- Assume remote peers are listening on the same port that we do.
+    let peerport = fromIntegral $ fromMaybe 5269 $ bind_addr >>= sockAddrPort
+    return $ (raddr `withPort` peerport,ConnectionData (Left (Local laddr)) XMPP)
 
-clientKey :: SocketLike sock => sock -> IO (ConnectionKey,ConnectionData)
+clientKey :: SocketLike sock => sock -> IO (SockAddr,ConnectionData)
 clientKey sock = do
-    addr <- getSocketName sock
-    paddr <- getPeerName sock
-    return $ (ClientKey addr,ConnectionData paddr XMPP)
+    laddr <- getSocketName sock
+    raddr <- getPeerName sock
+    return $ (laddr,ConnectionData (Right (Remote raddr)) XMPP)
 
 xmlifyRosterItems :: Monad m => Set Text -> Text -> Set Text -> ConduitM i Event m ()
 xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set)
@@ -1429,14 +1436,15 @@ xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set)
 sendRoster ::
     StanzaWrap a
     -> XMPPServerParameters
-    -> ConnectionKey
+    -> ClientAddress
     -> TChan Stanza
     -> IO ()
 sendRoster query xmpp clientKey replyto = do
-    let k = case stanzaOrigin query of
-             NetworkOrigin k _ -> Just k
-             LocalPeer -> Nothing -- local peer requested roster?
-    forM_ k $ \k -> do
+    let maddr = case stanzaOrigin query of
+             ClientOrigin addr _ -> Just addr
+             PeerOrigin {}       -> Nothing -- remote peer requested roster?
+             LocalPeer           -> Nothing -- local peer requested roster?
+    forM_ maddr $ \k -> do
     hostname <- xmppTellMyNameToClient xmpp clientKey
     let getlist f = do
             bs <- f xmpp k
@@ -1445,9 +1453,7 @@ sendRoster query xmpp clientKey replyto = do
     subscribers <- getlist xmppRosterSubscribers
     solicited   <- getlist xmppRosterSolicited
     subnone0    <- getlist xmppRosterOthers
-    jid <- case k of
-                ClientKey {} -> xmppTellClientHisName xmpp k -- LookupClientJID xmpp k
-                PeerKey {}   -> xmppTellClientNameOfPeer xmpp k (Set.toList buddies)
+    jid <- xmppTellClientHisName xmpp k -- LookupClientJID xmpp k
     let subnone = Set.union solicited subnone0 \\ Set.union buddies subscribers
     let subto = buddies \\ subscribers
     let subfrom = subscribers \\ buddies
@@ -1482,17 +1488,14 @@ sendRoster query xmpp clientKey replyto = do
     -}
 
 
-socketFromKey :: Server ConnectionKey ConnectionData releaseKey XML.Event -> ConnectionKey -> IO SockAddr
-socketFromKey sv k = do
+socketFromKey :: Server SockAddr ConnectionData releaseKey XML.Event -> ClientAddress -> IO (Remote SockAddr)
+socketFromKey sv (ClientAddress addr) = do
     map <- atomically $ readTVar (conmap sv)
-    let mcd = Map.lookup k map
+    let mcd = Map.lookup addr map
+        oops = Remote addr -- No connection data, so using incorrect address.
     case mcd of
-        Nothing -> case k of
-                    ClientKey addr -> return addr
-                    PeerKey addr -> return addr
-                        -- XXX: ? wrong address
-                        -- Shouldnt happen anyway.
-        Just cd -> return $ cdAddr $ cdata cd
+        Nothing -> return oops
+        Just cd -> return $ either (const oops) id $ cdAddr $ cdata cd
 
 class StanzaFirstTag a where
     stanzaFirstTag :: StanzaWrap a -> IO XML.Event
@@ -1652,8 +1655,8 @@ makeErrorStanza stanza = do
            ]
 
 monitor ::
-    Server ConnectionKey ConnectionData releaseKey XML.Event
-    -> ConnectionParameters ConnectionKey ConnectionData
+    Server SockAddr ConnectionData releaseKey XML.Event
+    -> ConnectionParameters SockAddr ConnectionData
     -> XMPPServerParameters
     -> IO b
 monitor sv params xmpp = do
@@ -1662,20 +1665,25 @@ monitor sv params xmpp = do
     quitVar <- atomically newEmptyTMVar
     fix $ \loop -> do
     action <- atomically $ foldr1 orElse
-      [ readTChan chan >>= \((k,u),e) -> return $ do
+      [ readTChan chan >>= \((addr,u),e) -> return $ do
         case e of
-            Connection pingflag xsrc xsnk -> do
-                wlog $ tomsg k "Connection"
-                outs <- forkConnection sv xmpp k u pingflag xsrc xsnk stanzas
-                xmppNewConnection xmpp k u outs
-            ConnectFailure addr -> return () -- wlog $ tomsg k "ConnectFailure"
-            EOF        -> do wlog $ tomsg k "EOF"
-                             xmppEOF xmpp k
-            HalfConnection In -> do
-                wlog $ tomsg k "ReadOnly"
-                control sv (Connect (callBackAddress k) params)
-            HalfConnection Out -> wlog $ tomsg k "WriteOnly"
-            RequiresPing -> return () -- wlog $ tomsg k "RequiresPing"
+            Connection pingflag xsrc xsnk
+                -> do wlog $ tomsg addr "Connection"
+                      outs <- forkConnection sv xmpp addr u pingflag xsrc xsnk stanzas
+                      xmppNewConnection xmpp addr u outs
+            ConnectFailure addr
+                -> do return () -- wlog $ tomsg k "ConnectFailure"
+            EOF -> do wlog $ tomsg addr "EOF"
+                      xmppEOF xmpp addr u
+            HalfConnection In
+                -> do wlog $ tomsg addr "ReadOnly"
+                      case cdAddr u of
+                        Left (Local _) -> control sv (Connect addr params)
+                        _              -> return () -- Don't call-back client connections.
+            HalfConnection Out
+                -> do wlog $ tomsg addr "WriteOnly"
+            RequiresPing
+                -> do return () -- wlog $ tomsg k "RequiresPing"
       , readTChan stanzas >>= \stanza -> return $ do
         {-
         dup <- case stanzaType stanza of
@@ -1692,7 +1700,7 @@ monitor sv params xmpp = do
 
         forkIO $ do
             case stanzaOrigin stanza of
-                NetworkOrigin k@(ClientKey {}) replyto ->
+                ClientOrigin k replyto ->
                     case stanzaType stanza of
                         RequestResource clientsNameForMe wanted -> do
                             sockaddr <- socketFromKey sv k
@@ -1755,7 +1763,7 @@ monitor sv params xmpp = do
                                 guard . not . null . mapMaybe (msgBody . snd) $ msgLangMap (stanzaType stanza)
                                 stanzaId stanza
                         _ -> return ()
-                NetworkOrigin k@(PeerKey {}) replyto ->
+                PeerOrigin k replyto ->
                     case stanzaType stanza of
                         PresenceRequestStatus {} -> do
                             xmppAnswerProbe xmpp k stanza replyto
@@ -1785,14 +1793,13 @@ monitor sv params xmpp = do
                 Message {} -> do
                   case stanzaOrigin stanza of
                     LocalPeer {} -> return ()
-                    NetworkOrigin _ replyto -> deliver replyto
+                    ClientOrigin _ replyto -> deliver replyto
+                    PeerOrigin   _ replyto -> deliver replyto
                 Error {} -> do
                   case stanzaOrigin stanza of
                     LocalPeer {} -> return ()
-                    NetworkOrigin k replyto -> do
-                         -- wlog $ "delivering error: " ++show (stanzaId stanza)
-                         -- wlog $ " from: " ++ show k
-                         deliver replyto
+                    ClientOrigin _ replyto -> deliver replyto
+                    PeerOrigin   _ replyto -> deliver replyto
                 _ -> return ()
         -- We need to clone in the case the stanza is passed on as for Message.
         verbosity <- xmppVerbosity xmpp
@@ -1803,9 +1810,9 @@ monitor sv params xmpp = do
         notping $ do
         let typ = Strict8.pack $ c ++ "->"++(concat . take 1 . words $ show (stanzaType stanza))++" "
             c = case stanzaOrigin stanza of
-                    LocalPeer -> "*"
-                    NetworkOrigin (ClientKey {}) _ -> "C"
-                    NetworkOrigin (PeerKey {})   _ -> "P"
+                    LocalPeer       -> "*"
+                    ClientOrigin {} -> "C"
+                    PeerOrigin {}   -> "P"
         wlog ""
         stanzaToConduit dup $$ prettyPrint typ
 
@@ -1821,27 +1828,41 @@ data ConnectionType = XMPP | Tox
     deriving (Eq,Ord,Enum,Show,Read)
 
 data ConnectionData = ConnectionData
-    { cdAddr :: SockAddr
+    { cdAddr :: Either (Local SockAddr)  -- Peer connection local address
+                       (Remote SockAddr) -- Client connection remote address
     , cdType :: ConnectionType
     }
     deriving (Eq,Ord,Show)
 
+addrToPeerKey :: Remote SockAddr -> PeerAddress
+addrToPeerKey (Remote raddr) = PeerAddress raddr
+
+addrFromClientKey :: ClientAddress -> Local SockAddr
+addrFromClientKey (ClientAddress laddr) = Local laddr
+
+classifyConnection :: SockAddr -> ConnectionData -> Either (PeerAddress, Local SockAddr)
+                                                           (ClientAddress, Remote SockAddr)
+classifyConnection saddr dta = case cdAddr dta of
+    Left  laddr -> Left  (PeerAddress saddr, laddr)
+    Right raddr -> Right (ClientAddress saddr, raddr)
+
 data XMPPServer
     = forall releaseKey.
-      XMPPServer { _xmpp_sv :: Server ConnectionKey ConnectionData releaseKey XML.Event
-                 , _xmpp_peer_params :: ConnectionParameters ConnectionKey ConnectionData
+      XMPPServer { _xmpp_sv :: Server SockAddr ConnectionData releaseKey XML.Event
+                 , _xmpp_peer_params :: ConnectionParameters SockAddr ConnectionData
                  }
 
-grokPeer :: XMPPServer -> ConnectionKey -> (SockAddr, ConnectionParameters ConnectionKey ConnectionData, Miliseconds)
-grokPeer sv (PeerKey addr) = (addr, _xmpp_peer_params sv, 10000)
+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) resolvPeer sv
+xmppConnections xsv@XMPPServer{_xmpp_sv=sv} = tcpManager (grokPeer xsv) (Just . Text.pack) resolve sv
  where
-    resolvPeer :: Text -> IO (Maybe ConnectionKey)
-    resolvPeer str = fmap PeerKey <$> listToMaybe <$> resolvePeer str
+    resolve :: Text -> IO (Maybe SockAddr)
+    resolve hostname = listToMaybe . map (\(PeerAddress addr) -> addr) <$> resolvePeer hostname
 
-xmppEventChannel :: XMPPServer -> TChan ((ConnectionKey, ConnectionData), ConnectionEvent Event)
+xmppEventChannel :: XMPPServer -> TChan ((SockAddr, ConnectionData), ConnectionEvent Event)
 xmppEventChannel XMPPServer{_xmpp_sv=sv} = serverEvent sv
 
 quitXmpp :: XMPPServer -> IO ()
diff --git a/ToxManager.hs b/ToxManager.hs
index 6ffa4840..bcc4d86d 100644
--- a/ToxManager.hs
+++ b/ToxManager.hs
@@ -26,7 +26,7 @@ import qualified Network.Tox.Onion.Transport as Tox
 import Presence
 import Text.Read
 import ToxToXMPP
-import XMPPServer                            (ConnectionKey)
+import XMPPServer                            (ClientAddress)
 import DPut
 
 
@@ -53,7 +53,7 @@ toxman :: Announcer
             -> [(String,TVar (BucketList Tox.NodeInfo))]
             -> Tox.Tox JabberClients
             -> PresenceState
-            -> ToxManager ConnectionKey
+            -> ToxManager ClientAddress
 toxman announcer toxbkts tox presence = ToxManager
     { activateAccount        = \k pubname seckey -> do
         dput XMan $ "toxman ACTIVATE " ++ show (Tox.key2id $ toPublic seckey)
diff --git a/ToxToXMPP.hs b/ToxToXMPP.hs
index d8b704b7..adeb7455 100644
--- a/ToxToXMPP.hs
+++ b/ToxToXMPP.hs
@@ -62,7 +62,7 @@ import qualified Network.Tox.Onion.Transport as Tox
          ;import Network.Tox.Onion.Transport (OnionData (..))
 import Presence
 import Text.Read
-import XMPPServer                            (ConnectionKey)
+import XMPPServer                            (ClientAddress)
 #ifdef THREAD_DEBUG
 import Control.Concurrent.Lifted.Instrument
 #else
@@ -123,7 +123,7 @@ key2jid nospam key = T.pack $ show $ NoSpamId nsp key
     nlo = fromIntegral (0x0FFFF .&. nospam) :: Word16
     nhi = fromIntegral (0x0FFFF .&. (nospam `shiftR` 16)) :: Word16
 
-type JabberClients = Map.Map ConnectionKey PerClient
+type JabberClients = Map.Map ClientAddress PerClient
 
 data PerClient = PerClient
     { pcDeliveredFRs :: TVar (Set.Set Tox.FriendRequest)
@@ -328,7 +328,7 @@ dispatch tx (OnionRouted  theirkey (OnionFriendRequest fr) ) = do
                   , txPresence  = st } = tx
     k2c <- atomically $ do
         refs <- readTVar (accountExtra acnt)
-        k2c <- Map.intersectionWith (,) refs <$> readTVar (keyToChan st)
+        k2c <- Map.intersectionWith (,) refs <$> readTVar (ckeyToChan st)
         clients <- readTVar (clients st)
         return $ Map.intersectionWith (,) k2c clients
     -- TODO: Below we're using a hard coded default as their jabber user id.
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 8e34d4fe..7aa5cd2c 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -1537,7 +1537,7 @@ newXmmpSink session@(Tox.NCrypto { ncOutgoingQueue = outGoingQVar, ncPacketQueue
 -- order to set up translating conduits that simulate a remote XMPP server.
 announceToxJabberPeer :: PublicKey  -- ^ This node's long-term user key.
                       -> PublicKey -- ^ Remote tox node's long-term user key.
-                      -> TChan ((ConnectionKey,ConnectionData), Tcp.ConnectionEvent XML.Event)
+                      -> TChan ((SockAddr,ConnectionData), Tcp.ConnectionEvent XML.Event)
                       -> SockAddr -- ^ Local bind address for incoming Tox packets.
                       -> SockAddr -- ^ Remote address for this connection.
                       -> STM Bool
@@ -1547,7 +1547,7 @@ announceToxJabberPeer :: PublicKey  -- ^ This node's long-term user key.
 announceToxJabberPeer me them echan laddr saddr pingflag tsrc tsnk
     = do
      atomically $ writeTChan echan
-        ( (PeerKey saddr, ConnectionData laddr XMPPServer.Tox )
+        ( (saddr, ConnectionData (Left (Local laddr)) XMPPServer.Tox )
         , Tcp.Connection pingflag xsrc xsnk )
      return Nothing
  where
diff --git a/src/Network/Tox/NodeId.hs b/src/Network/Tox/NodeId.hs
index e3c6fb36..3a732b43 100644
--- a/src/Network/Tox/NodeId.hs
+++ b/src/Network/Tox/NodeId.hs
@@ -278,6 +278,16 @@ b64digit '-' = True
 b64digit '/' = True
 b64digit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'z') || ( 'A' <= c && c <= 'Z')
 
+ip_w_port :: Int -> RP.ReadP (IP, PortNumber)
+ip_w_port i = do
+            ip <- RP.between (RP.char '[') (RP.char ']')
+                         (IPv6 <$> RP.readS_to_P (readsPrec i))
+                  RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i))
+            _    <- RP.char ':'
+            port <- toEnum <$> RP.readS_to_P (readsPrec i)
+            return (ip, port)
+
+
 instance Read NodeInfo where
   readsPrec i = RP.readP_to_S $ do
     RP.skipSpaces
@@ -292,15 +302,7 @@ instance Read NodeInfo where
                               _                              -> fail "Bad node id."
                       return (nid,addrstr)
     (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) )
-    let raddr = do
-            ip <- RP.between (RP.char '[') (RP.char ']')
-                         (IPv6 <$> RP.readS_to_P (readsPrec i))
-                  RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i))
-            _    <- RP.char ':'
-            port <- toEnum <$> RP.readS_to_P (readsPrec i)
-            return (ip, port)
-
-    (ip,port) <- case RP.readP_to_S raddr addrstr of
+    (ip,port) <- case RP.readP_to_S (ip_w_port i) addrstr of
                     [] -> fail "Bad address."
                     ((ip,port),_):_ -> return (ip,port)
     return $ NodeInfo nid ip port