1 files changed, 117 insertions, 56 deletions

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