Made client's handshake to/from attributes available to xmppTellNameToClient.

4 files changed, 160 insertions, 79 deletions

diff --git a/dht/Presence/Nesting.hs b/dht/Presence/Nesting.hs
index 403d63cf..a9e550d4 100644
--- a/dht/Presence/Nesting.hs
+++ b/dht/Presence/Nesting.hs
@@ -24,12 +24,10 @@ doNestingXML :: Monad m => NestingXML o m r -> ConduitM Event o m r
 doNestingXML m =
     evalStateC (XMLState 0 StrictNil) (trackNesting .| m)
 
-startNestingXML :: Monad m => NestingXML o m r -> ConduitM Event o m (r, XMLState)
-startNestingXML m =
-    runStateC (XMLState 0 StrictNil) (trackNesting .| m)
-
-finishNestingXML :: Monad m => XMLState -> NestingXML o m r -> ConduitM Event o m r
-finishNestingXML = evalStateC
+startNestingXML :: Monad m => NestingXML o m r -> ConduitM Event o m (r, NestingXML o m ())
+startNestingXML m = do
+    (r,st) <- runStateC (XMLState 0 StrictNil) (trackNesting .| m)
+    return (r, lift $ put st)
 
 nesting :: Monad m => NestingXML o m Int
 nesting = lift $ (return . nestingLevel) =<< get
diff --git a/dht/Presence/Presence.hs b/dht/Presence/Presence.hs
index 866aad78..c54c3659 100644
--- a/dht/Presence/Presence.hs
+++ b/dht/Presence/Presence.hs
@@ -13,6 +13,7 @@ import Control.Concurrent
 import Control.Concurrent.Lifted.Instrument
 #endif
 
+import Control.Arrow
 import Control.Concurrent.STM
 import Control.Monad.Trans
 import Network.Socket ( SockAddr(..) )
@@ -133,17 +134,21 @@ newPresenceState cw toxman sv man = atomically $ do
         return $ st { toxManager = fmap ($ st) toxman }
 
 
-nameForClient :: PresenceState stat -> ClientAddress -> IO Text
-nameForClient state k = do
+nameForClient' :: PresenceState stat -> Maybe Text -> Maybe Text -> ClientAddress -> IO Text
+nameForClient' state mbNameForMe mbTheirName k = do
     mc <- atomically $ do
         cmap <- readTVar (clients state)
         return $ Map.lookup k cmap
     case mc of
-        Nothing -> textHostName
+        Nothing -> textHostName -- TODO: We can use mbNameForMe to initialize the clientProfile
         Just client -> case clientProfile client of
             "."     -> textHostName
             profile -> return profile
 
+nameForClient :: PresenceState stat -> ClientAddress -> IO Text
+nameForClient state k = nameForClient' state Nothing Nothing k
+
+
 presenceHooks :: PresenceState stat -> Map Text MUC
                                       -> Int
                                       -> Maybe SockAddr -- ^ client-to-server bind address
@@ -152,7 +157,7 @@ presenceHooks :: PresenceState stat -> Map Text MUC
 presenceHooks state chats verbosity mclient mpeer = XMPPServerParameters
     { xmppChooseResourceName        = chooseResourceName state
     , xmppTellClientHisName         = tellClientHisName state
-    , xmppTellMyNameToClient        = nameForClient state
+    , xmppTellMyNameToClient        = nameForClient' state
     , xmppTellMyNameToPeer          = \(Local addr) -> return $ addrToText addr
     , xmppTellPeerHisName           = return . peerKeyToText
     , xmppNewConnection             = newConn state
@@ -726,8 +731,12 @@ deliverMessage state fail msg =
         fromMaybe (do dput XJabber $ "Unknown peer " ++ show senderk
                       fail)
                 $ Map.lookup senderk pchans
-            <&> \(Conn { connChan = sender_chan
-                       , auxData  = ConnectionData (Left laddr) ctyp cprof _ }) -> do
+            <&> \Conn { connChan = sender_chan
+                      , auxData  = ConnectionData { cdAddr    = Left laddr
+                                                  , cdType    = ctyp
+                                                  , cdProfile = cprof
+                                                  }
+                      } -> do
         fromMaybe (do dput XJabber $ "Message missing \"to\" attribute."
                       fail)
                 $ (stanzaTo msg) <&> \to -> do
@@ -916,9 +925,7 @@ informPeerPresence state k stanza = do
     dput XJabber $ "xmppInformPeerPresence (length clients="++show (length clients)++")"
     (ctyp,cprof) <- atomically $ do
         mconn <- Map.lookup k <$> readTVar (pkeyToChan state)
-        return $ fromMaybe (XMPP,".") $ do
-            ConnectionData _ ctyp cprof _ <- auxData <$> mconn
-            return (ctyp,cprof)
+        return $ fromMaybe (XMPP,".") $ (cdType &&& cdProfile) . auxData <$> mconn
     forM_ clients $ \(ck,con,client) -> do
         -- (TODO: appropriately authorized clients only.)
         -- For now, all "available" clients (available = sent initial presence)
@@ -1263,7 +1270,11 @@ 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 profile _ } -> do
+        <&> \Conn { auxData = ConnectionData { cdAddr    = Left laddr
+                                             , cdType    = ctyp
+                                             , cdProfile = profile
+                                             }
+                  } -> do
     (mine,totup) <- case (ctyp,profile) of
         (Tox,p) -> let (u,h,r) = splitJID to
                    in return ( h == p, (u,h,r) )
@@ -1412,8 +1423,12 @@ peerInformSubscription state fail k stanza = do
         cmap <- readTVar (clients state)
         return (pktc,cktc,cmap)
     fromMaybe fail $ Map.lookup k ktc
-        <&> \(Conn { connChan=sender_chan
-                   , auxData =ConnectionData (Left laddr) ctyp profile _ }) -> do
+        <&> \Conn { connChan = sender_chan
+                  , auxData = ConnectionData { cdAddr    = Left laddr
+                                             , cdType    = ctyp
+                                             , cdProfile = profile }
+                  } -> do
+
     let man = manager state profile
     (from_u,from_h,_) <- case ctyp of
         Tox  -> return $ splitJID from
diff --git a/dht/Presence/XMPPServer.hs b/dht/Presence/XMPPServer.hs
index 0aef1ed6..89fd76b6 100644
--- a/dht/Presence/XMPPServer.hs
+++ b/dht/Presence/XMPPServer.hs
@@ -129,8 +129,10 @@ data XMPPServerParameters =
       --
       -- A Left result causes an error stanza to be sent instead.
       xmppChooseResourceName :: ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO (Either Text Text)
-    , -- | This should indicate the server's hostname that all client's see.
-      xmppTellMyNameToClient :: ClientAddress -> IO Text
+    , -- | This should indicate the server's hostname that the client will see.
+      -- The first two arguments are the "to" and "from" attributes,
+      -- respectively, that the client sent in its greeting to the server.
+      xmppTellMyNameToClient :: Maybe Text -> Maybe Text -> ClientAddress -> IO Text
     , xmppTellMyNameToPeer   :: Local SockAddr -> IO Text
     , xmppTellClientHisName  :: ClientAddress -> IO Text
     , xmppTellPeerHisName    :: PeerAddress -> IO Text
@@ -476,16 +478,14 @@ C->Unrecognized </iq>
 
 -- Sends all stanzas to announce channel except ping, for which it sends a pong
 -- to the output channel.
-xmppInbound :: Maybe Text -- ^ "to" attribute sent from remote
-                -> Maybe Text -- ^ "from" attribute sent from remote
-                -> ConnectionData
+xmppInbound :: ConnectionData
                 -> (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
                 -> NestingXML o IO ()
-xmppInbound stream_name stream_remote cdta (namespace,tellmyname,tellyourname,mkorigin) pingflag stanzas output donevar =
+xmppInbound cdta (namespace,tellmyname,tellyourname,mkorigin) pingflag stanzas output donevar =
     fix $ \loop -> do
     -- liftIO . wlog $ "waiting for stanza."
     (chan,clsrs) <- liftIO . atomically $
@@ -540,7 +540,7 @@ xmppInbound stream_name stream_remote cdta (namespace,tellmyname,tellyourname,mk
                             }
               stype -> ioWriteChan stanzas Stanza
                             { stanzaType      = case stype of
-                                RequestResource _ rsc -> RequestResource stream_name rsc
+                                RequestResource _ rsc -> RequestResource (cdTheirNameForMe cdta) rsc
                                 _                     -> stype
                             , stanzaId        = mid
                             , stanzaTo        = mto
@@ -911,44 +911,81 @@ forkConnection :: Server PeerAddress ConnectionData releaseKey XML.Event
                 -> ConduitT (Flush XML.Event) Void IO ()
                 -> TChan Stanza
                 -> MVar ()
-                -> IO (TChan Stanza)
-forkConnection sv xmpp saddr cdta pingflag src snk stanzas pp_mvar = do
+                -> IO (TChan Stanza, ConnectionData)
+forkConnection sv xmpp saddr cdta0 pingflag src snk stanzas pp_mvar = do
     -- client.PeerAddress {peerAddress = [::1]:5222}
-    let lbl n = concat [ n
-                       , Text.unpack (Text.drop 7 namespace) -- "client" or "server"
-                       , "."
-                       , case cdProfile cdta of
-                            _ | Right _ <- cdAddr cdta -> show saddr
-                            "."                        -> show saddr
-                            mytoxname                  -> show saddr {- TODO: remote tox peer name? -} ]
+    let auxAddr = cdAddr cdta0
 
-        auxAddr = cdAddr cdta
+        is_client = case auxAddr of { Right _ -> True ; Left _ -> False }
 
-        clientOrServer@(namespace,tellmyname,telltheirname,_) = case auxAddr of
-            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 saddr
-                                          , PeerOrigin saddr)
+        (namespace,clientOrServer0) = case auxAddr of
+            Right _    -> ( "jabber:client"
+                          , ( xmppTellMyNameToClient xmpp Nothing Nothing $ ClientAddress $ peerAddress saddr
+                            , xmppTellClientHisName xmpp $ ClientAddress $ peerAddress saddr
+                            , ClientOrigin $ ClientAddress $ peerAddress saddr ) )
+            Left laddr -> ( "jabber:server"
+                          , ( xmppTellMyNameToPeer xmpp laddr
+                            , xmppTellPeerHisName xmpp saddr
+                            , PeerOrigin saddr) )
+
+        updateNameField f (tmn,ttn,o) = (namespace,f tmn,ttn,o)
+
+        lbl n = concat [ n
+                       , Text.unpack (Text.drop 7 namespace) -- "client" or "server"
+                       , "."
+                       , case cdProfile cdta0 of
+                            _ | Right _ <- auxAddr -> show saddr
+                            "."                    -> show saddr
+                            mytoxname              -> show saddr {- TODO: remote tox peer name? -} ]
+
+
+        realDoGreeting = await >>= \case
+            Just EventBeginDocument ->
+                nextElement >>= \case
+                    Just xml ->
+                        forM (elementAttrs "stream" xml) $ \stream_attrs -> do
+                            -- liftIO $ dput XMisc $ "STREAM ATTRS "++show stream_attrs
+                            let stream_name   = lookupAttrib "to"   stream_attrs
+                                stream_remote = lookupAttrib "from" stream_attrs
+                             -- xmpp_version = lookupAttrib "version" stream_attrs
+                            liftIO $ atomically $ writeTVar (cdRemoteName cdta0) stream_remote
+                            return (stream_name, stream_remote)
+                    Nothing -> return Nothing
+            _ -> return Nothing
+
+    (clientOrServer@(namespace,tellmyname,telltheirname,_), (cdta, src', doGreeting))
+        <- if is_client
+            then do
+                -- For a client, we can wait for them to greet us before we send them
+                -- any information.
+                (srcSealed,(mb,resume)) <- src $$+ startNestingXML realDoGreeting
+                let stream_name = mb >>= fst
+                    stream_remote = mb >>= snd
+                    cdta = cdta0 { cdTheirNameForMe = stream_name
+                                 , cdTheirName      = stream_remote
+                                 }
+                    newName _ = xmppTellMyNameToClient xmpp stream_name stream_remote
+                                    $ ClientAddress $ peerAddress saddr
+                atomically $
+                    modifyTVar' (conmap sv) $
+                        Map.adjust (\c -> c { cdata = cdta }) saddr
+                return ( updateNameField newName clientOrServer0
+                       , (cdta, unsealConduitT srcSealed, resume >> return mb) )
+            else -- For a server, this is a no-op.
+                 return ( updateNameField id clientOrServer0
+                        , (cdta0, src, realDoGreeting) )
 
     output <- atomically newTChan
     rdone <- atomically newEmptyTMVar
     forkLabeled (lbl "xmpp-reader.") $ do
         -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show)
-        runConduit $ (.|) src $
+        runConduit $ (.|) src' $
             -- :: ConduitM Event o IO ()
             doNestingXML $ do
-                withXML $ \begindoc -> do
-                when (begindoc==EventBeginDocument) $ do
-                whenJust nextElement $ \xml -> do
-                withJust (elementAttrs "stream" xml) $ \stream_attrs -> do
-                -- liftIO $ dput XMisc $ "STREAM ATTRS "++show stream_attrs
-                let stream_name   = lookupAttrib "to"   stream_attrs
-                    stream_remote = lookupAttrib "from" stream_attrs
-                 -- xmpp_version = lookupAttrib "version" stream_attrs
-                liftIO $ atomically $ writeTVar (cdRemoteName cdta) stream_remote
-                xmppInbound stream_name stream_remote cdta clientOrServer pingflag stanzas output rdone
+              doGreeting >>= \case
+                Just (stream_name, stream_remote) ->
+                  xmppInbound cdta clientOrServer pingflag stanzas output rdone
+                Nothing -> return ()
         atomically $ putTMVar rdone ()
         wlog $ "end reader fork: " ++ lbl ""
 
@@ -1087,7 +1124,7 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas pp_mvar = do
                 ]
             what
         wlog $ "end xmpp-pre fork: " ++ show (lbl "")
-    return output
+    return (output, cdta)
 
 {-
 data Peer = Peer
@@ -1121,7 +1158,9 @@ peerKey bind_addr (sock,(laddr,Remote raddr)) = do
              , ConnectionData { cdAddr       = Left laddr
                               , cdType       = XMPP
                               , cdProfile    = "."
-                              , cdRemoteName = rname } )
+                              , cdRemoteName = rname
+                              , cdTheirNameForMe = Nothing
+                              , cdTheirName  = Nothing } )
 
 clientKey :: SocketLike sock => (sock, (Local SockAddr,Remote SockAddr)) -> IO (PeerAddress,ConnectionData)
 clientKey (sock,(laddr,Remote raddr)) = do
@@ -1138,7 +1177,9 @@ clientKey (sock,(laddr,Remote raddr)) = do
              , ConnectionData { cdAddr       = Right (Remote raddr) -- FIXME: This is a bad way to detect client/peer.
                               , cdType       = XMPP
                               , cdProfile    = "."
-                              , cdRemoteName = rname } )
+                              , cdRemoteName = rname
+                              , cdTheirNameForMe = Nothing
+                              , cdTheirName  = Nothing } )
 
 
 xmlifyRosterItems :: Monad m => Set Text -> Text -> Set Text -> ConduitM i Event m ()
@@ -1154,17 +1195,18 @@ xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set)
 
 sendRoster ::
     StanzaWrap a
+    -> Server PeerAddress ConnectionData releaseKey xml
     -> XMPPServerParameters
     -> ClientAddress
     -> TChan Stanza
     -> IO ()
-sendRoster query xmpp clientKey replyto = do
+sendRoster query sv xmpp clientKey replyto = 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
+    hostname <- svTellMyName sv xmpp clientKey
     let getlist f = do
             bs <- f xmpp k
             return (Set.fromList bs) -- js)
@@ -1278,13 +1320,24 @@ makeErrorStanza' stanza err attrs = do
            , endTag
            ]
 
+svTellMyName :: Server PeerAddress ConnectionData releaseKey xml
+                -> XMPPServerParameters
+                -> ClientAddress
+                -> IO Text
+svTellMyName sv xmpp k@(ClientAddress saddr) = do
+    mc <- atomically $
+        fmap cdata . Map.lookup (PeerAddress saddr) <$> readTVar (conmap sv)
+    let me = mc >>= cdTheirNameForMe
+        them = mc >>= cdTheirName
+    xmppTellMyNameToClient xmpp me them k
+
 monitor ::
     Server PeerAddress ConnectionData releaseKey XML.Event
     -> ConnectionParameters PeerAddress ConnectionData
     -> XMPPServerParameters
     -> IO b
 monitor sv params xmpp = do
-    chan <- return $ serverEvent sv
+    let chan = serverEvent sv
     stanzas <- atomically newTChan
     quitVar <- atomically newEmptyTMVar
     pp_mvar <- newMVar () -- Lock for synchronous pretty-printing of stanzas in log.
@@ -1296,16 +1349,18 @@ monitor sv params xmpp = do
         case e of
             Connection pingflag xsrc xsnk
                 -> do wlog $ tomsg addr "Connection"
-                      outs <- forkConnection sv xmpp addr u pingflag xsrc xsnk stanzas pp_mvar
+                      (outs,u') <- forkConnection sv xmpp addr u pingflag xsrc xsnk stanzas pp_mvar
                       -- /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
+                      xmppNewConnection xmpp (peerAddress addr) u' outs
             ConnectFailure addr
                 -> do return () -- wlog $ tomsg k "ConnectFailure"
             EOF -> do wlog $ tomsg addr "EOF"
                       -- /addr/ may be a peer or a client.  So we'll strip off
                       -- the PeerAddress constructor before exposing it.
-                      xmppEOF xmpp (peerAddress addr) u
+                      xmppEOF xmpp (peerAddress addr) u -- Note: cdTheirName and cdTheirNameForMe are with their
+                                                        -- default values rather than the updated versions provided
+                                                        -- by 'forkConnection'.
             HalfConnection In
                 -> do wlog $ tomsg addr "ReadOnly"
                       case cdAddr u of
@@ -1359,7 +1414,7 @@ monitor sv params xmpp = do
                 $ \(k,((rkey,muckey),(replyto,r))) -> do
                     (mine,ChatTransaction no cjid cnick es) <- readRoom k r
                     return $ do
-                        me <- xmppTellMyNameToClient xmpp k
+                        me <- svTellMyName sv xmpp k
                         dput XJabber $ "CHAT " ++ Text.unpack rkey ++ ": <" ++ Text.unpack cnick ++ "> " ++ show es
                         forM_ es $ \case
                             Join | mine -> sendRoomOccupants muckey me cnick rkey r replyto
@@ -1387,7 +1442,7 @@ monitor sv params xmpp = do
                                                               else Map.insert k m' jrs
                                     writeTVar joined_rooms jrs'
                             Talk talk   -> do
-                                them <- xmppTellClientHisName xmpp k
+                                them <- svTellMyName sv xmpp k
                                 stanza <- makeMessageEx "jabber:client" (roomjid muckey me rkey cnick) them GroupChatMsg talk
                                 ioWriteChan replyto stanza
                                 return ()
@@ -1475,7 +1530,7 @@ applyStanza sv joined_rooms quitVar xmpp stanza = do
                 sockaddr <- socketFromKey sv k
                 xmppChooseResourceName xmpp k sockaddr clientsNameForMe wanted >>= \case
                     Right rsc0 -> do
-                        hostname <- xmppTellMyNameToClient xmpp k
+                        hostname <- svTellMyName sv xmpp k
                         let rsc = unsplitJID (n,hostname,r) where (n,_,r) = splitJID rsc0
                         let reply = iq_bind_reply (stanzaId stanza) rsc
                         sendReply quitVar SetResource reply replyto
@@ -1486,19 +1541,19 @@ applyStanza sv joined_rooms quitVar xmpp stanza = do
                               (requestVersion rsc hostname)
                           >>= ioWriteChan replyto
                     Left err -> do
-                        hostname <- xmppTellMyNameToClient xmpp k
+                        hostname <- svTellMyName sv xmpp k
                         reply <- makeErrorStanza' stanza NotAllowed []
                         sendReply quitVar (Error NotAuthorized (head reply)) reply replyto
             SessionRequest -> do
-                me <- xmppTellMyNameToClient xmpp k
+                me <- svTellMyName sv xmpp k
                 let reply = iq_session_reply (stanzaId stanza) me
                 sendReply quitVar Pong reply replyto
             RequestRoster -> do
-                sendRoster stanza xmpp k replyto
+                sendRoster stanza sv xmpp k replyto
                 xmppSubscribeToRoster xmpp k
             PresenceStatus {} -> do
                 let mucs = xmppGroupChat xmpp
-                me <- xmppTellMyNameToClient xmpp k
+                me <- svTellMyName sv xmpp k
                 if | Just to <- stanzaTo stanza
                    , (Just room,h,mnick) <- splitJID to
                    , let roomjid = unsplitJID ((Just room,h,Nothing))
@@ -1550,7 +1605,7 @@ applyStanza sv joined_rooms quitVar xmpp stanza = do
             NotifyClientVersion name version -> do
                 enableClientHacks name version replyto
             RequestInfo mnode -> do
-                me <- xmppTellMyNameToClient xmpp k
+                me <- svTellMyName sv xmpp k
                 let unavail = let query = "{http://jabber.org/protocol/disco#info}info"
                                   reply = iq_service_unavailable (stanzaId stanza) me query
                                in return (Error ServiceUnavailable (head reply), reply)
@@ -1608,7 +1663,7 @@ applyStanza sv joined_rooms quitVar xmpp stanza = do
                 sendReply quitVar rtyp reply replyto
             RequestItems mnode -> do
                 -- let query = "{http://jabber.org/protocol/disco#items}query"
-                me <- xmppTellMyNameToClient xmpp k
+                me <- svTellMyName sv xmpp k
                 let unavail = let query = "{http://jabber.org/protocol/disco#info}info"
                                   reply = iq_service_unavailable (stanzaId stanza) me query
                               in return (Error ServiceUnavailable (head reply), reply)
@@ -1635,12 +1690,12 @@ applyStanza sv joined_rooms quitVar xmpp stanza = do
                          return (Items, reply)
                 sendReply quitVar rtyp reply replyto
             UnrecognizedQuery query -> do
-                me <- xmppTellMyNameToClient xmpp k
+                me <- svTellMyName sv xmpp k
                 let reply = iq_service_unavailable (stanzaId stanza) me query
                 sendReply quitVar (Error ServiceUnavailable (head reply)) reply replyto
             Message { msgType = GroupChatMsg } -> do
                 let mucs = xmppGroupChat xmpp
-                me <- xmppTellMyNameToClient xmpp k
+                me <- svTellMyName sv xmpp k
                 if | Just to <- stanzaTo stanza
                    , (Just room,h,mnick) <- splitJID to
                    , let roomjid = unsplitJID ((Just room,h,Nothing))
@@ -1732,7 +1787,13 @@ data ConnectionData = ConnectionData
 
       -- Initially Nothing, when the remote end identifies itself by a given name,
       -- the result will be stored here.
-    , cdRemoteName :: TVar (Maybe Text)
+    , cdRemoteName :: TVar (Maybe Text) -- This is similar to 'cdTheirName' except that
+                                        -- it is available for remote xmpp servers and to
+                                        -- the 'xmppEOF' function.
+    , cdTheirNameForMe :: Maybe Text -- (client only) "to" attribute sent with <stream>
+                                     -- Also: currently unavailable to 'xmppEOF'
+    , cdTheirName :: Maybe Text -- (client only) "from" attribute sent with <stream>
+                                -- Also: currently unavailable to 'xmppEOF'
     }
 
 addrToPeerKey :: Remote SockAddr -> PeerAddress
diff --git a/dht/examples/dhtd.hs b/dht/examples/dhtd.hs
index d7c817ca..f9dc777d 100644
--- a/dht/examples/dhtd.hs
+++ b/dht/examples/dhtd.hs
@@ -1366,17 +1366,24 @@ onNewToxSession runio sv ssvar invc ContactInfo{accounts} addrTox netcrypto = do
 
     uniqkey <- xor24 <$> hash24 (them netcrypto) <*> hash24 (me netcrypto)
 
+    let me_dot_tox = xmppHostname $ me netcrypto
+        them_dot_tox = xmppHostname $ them netcrypto
+
     c <- atomically $ do
         mc <- Map.lookup uniqkey <$> readTVar ssvar
         case mc of
             Nothing -> do
                 announce <- do
-                    v <- newTVar Nothing
+                    v <- newTVar $ Just them_dot_tox
                     let ck       = uniqueAsKey uniqkey
-                        condta s = ConnectionData (Left (Local addrTox))
-                                                XMPPServer.Tox
-                                                (xmppHostname $ me s)
-                                                v
+                        condta s = ConnectionData
+                            { cdAddr           = Left (Local addrTox)
+                            , cdType           = XMPPServer.Tox
+                            , cdProfile        = me_dot_tox
+                            , cdRemoteName     = v
+                            , cdTheirNameForMe = Just me_dot_tox
+                            , cdTheirName      = Just them_dot_tox
+                            }
                     return $ \s e -> writeTChan (xmppEventChannel sv) ( (ck, condta s), e)
                 c <- newAggregateSession $ onStatusChange announce
                 modifyTVar' ssvar $ Map.insert uniqkey c