3 files changed, 29 insertions, 25 deletions

diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index 244bbead..befe47e1 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -578,17 +578,13 @@ deliverMessage state fail msg =
         mto <- fmap join $ mapM rewriteJIDForPeer (stanzaTo msg)
         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))
+        fromMaybe fail $ (Map.lookup k chans) <&> \conn -> do
         -- original 'from' address is discarded.
-        let from' = unsplitJID (n,addrToText laddr,r)
+        from' <- forClient state senderk (return Nothing)
+                        $ return . Just . clientJID conn
         -- dup <- atomically $ cloneStanza (msg { stanzaTo=Just to', stanzaFrom=Just from' })
-        let dup = (msg { stanzaTo=Just to', stanzaFrom=Just from' })
-        sendModifiedStanzaToPeer dup chan
+        let dup = (msg { stanzaTo=Just to', stanzaFrom=from' })
+        sendModifiedStanzaToPeer dup (connChan conn)
       PeerOrigin senderk _ -> do
         (pchans,cchans) <- atomically $ do
             pc <- readTVar (pkeyToChan state)
@@ -596,14 +592,14 @@ deliverMessage state fail msg =
             return (pc,cc)
         fromMaybe fail $ (Map.lookup senderk pchans)
             <&> \(Conn { connChan = sender_chan
-                       , auxData  = ConnectionData (Left laddr) ctyp }) -> do
+                       , auxData  = ConnectionData (Left laddr) ctyp cprof }) -> do
         fromMaybe fail $ (stanzaTo msg) <&> \to -> do
         (mine,(n,h,r)) <- rewriteJIDForClient laddr to []
         if not mine then fail else do
         let to' = unsplitJID (n,h,r)
         let (cmapVar,ckey) = case ctyp of
-                Tox  -> (clientsByProfile state , n <&> (<> ".tox") )
-                XMPP -> (clientsByUser    state , n                 )
+                Tox  -> (clientsByProfile state , Just cprof )
+                XMPP -> (clientsByUser    state , n          )
         cmap <- atomically . readTVar $ cmapVar
         chans <- fmap (fromMaybe []) $ do
             forM (ckey >>= flip Map.lookup cmap) $ \presence_container -> do
@@ -1084,14 +1080,12 @@ peerSubscriptionRequest state fail k stanza chan = do
         cmap <- readTVar (clients state)
         return (pktc,cktc,cmap)
     fromMaybe fail $ (Map.lookup k pktc)
-        <&> \Conn { auxData=ConnectionData (Left laddr) ctyp } -> do
+        <&> \Conn { auxData=ConnectionData (Left laddr) ctyp profile } -> 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
-    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
@@ -1225,7 +1219,7 @@ peerInformSubscription state fail k stanza = do
         return (pktc,cktc,cmap)
     fromMaybe fail $ (Map.lookup k ktc)
         <&> \(Conn { connChan=sender_chan
-                   , auxData =ConnectionData (Left laddr) ctyp }) -> do
+                   , auxData =ConnectionData (Left laddr) ctyp profile}) -> do
     (_,(from_u,from_h,_)) <- rewriteJIDForClient laddr from []
     let from'' = unsplitJID (from_u,from_h,Nothing)
         muser = do
@@ -1237,8 +1231,6 @@ 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
-    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,) addrs `intersect` subs
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 1de6a26a..49cfbb95 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -1254,8 +1254,9 @@ forkConnection :: Server SockAddr ConnectionData releaseKey XML.Event
                 -> Sink (Flush XML.Event) IO ()
                 -> TChan Stanza
                 ->  IO (TChan Stanza)
-forkConnection sv xmpp saddr (ConnectionData auxAddr _) pingflag src snk stanzas = do
-    let clientOrServer@(namespace,tellmyname,telltheirname,_) = case auxAddr of
+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))
@@ -1414,13 +1415,19 @@ peerKey bind_addr sock = do
              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)
+    return $ ( raddr `withPort` peerport
+             , ConnectionData { cdAddr    = Left (Local laddr)
+                              , cdType    = XMPP
+                              , cdProfile = "." } )
 
 clientKey :: SocketLike sock => sock -> IO (SockAddr,ConnectionData)
 clientKey sock = do
     laddr <- getSocketName sock
     raddr <- getPeerName sock
-    return $ (laddr,ConnectionData (Right (Remote raddr)) XMPP)
+    return $ ( laddr
+             , ConnectionData { cdAddr    = Right (Remote raddr)
+                              , cdType    = XMPP
+                              , cdProfile = "." } )
 
 xmlifyRosterItems :: Monad m => Set Text -> Text -> Set Text -> ConduitM i Event m ()
 xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set)
@@ -1830,7 +1837,11 @@ data ConnectionType = XMPP | Tox
 data ConnectionData = ConnectionData
     { cdAddr :: Either (Local SockAddr)  -- Peer connection local address
                        (Remote SockAddr) -- Client connection remote address
-    , cdType :: ConnectionType
+    , cdType    :: ConnectionType
+    , cdProfile :: Text -- Currently ignored for clients.  Instead, see
+                        -- 'clientProfile' field of 'ClientState'.
+                        --
+                        -- For peers: "." for XMPP, otherwise the ".tox" hostname.
     }
     deriving (Eq,Ord,Show)
 
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 7aa5cd2c..3d6b5f7b 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -1547,11 +1547,12 @@ announceToxJabberPeer :: PublicKey  -- ^ This node's long-term user key.
 announceToxJabberPeer me them echan laddr saddr pingflag tsrc tsnk
     = do
      atomically $ writeTChan echan
-        ( (saddr, ConnectionData (Left (Local laddr)) XMPPServer.Tox )
+        ( (saddr, ConnectionData (Left (Local laddr)) XMPPServer.Tox (toHostname me) )
         , Tcp.Connection pingflag xsrc xsnk )
      return Nothing
  where
-    xsrc = tsrc =$= toxToXmpp laddr me (T.pack $ show (Tox.key2id them) ++ ".tox")
+    toHostname k = T.pack $ show (Tox.key2id k) ++ ".tox"
+    xsrc = tsrc =$= toxToXmpp laddr me (toHostname them)
     xsnk = flushPassThrough xmppToTox =$= tsnk
 
 vShowMe :: Tox.ViewSnapshot -> Int -> B.ByteString