xmpp: cache stream name

1 files changed, 74 insertions, 20 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index ae861a61..0d2d479b 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -42,6 +42,8 @@ module XMPPServer
     , greet'
     , (<&>)
     , grokStanza
+    , Uniq24(..)
+    , uniqueAsKey
     ) where
 
 import ConnectionKey
@@ -56,6 +58,8 @@ import qualified Connection
 import Util
 import Network.Address (getBindAddress, sockAddrPort)
 
+import Data.Bits
+import Data.Word
 import Debug.Trace
 import Control.Monad.Trans (lift)
 import Control.Monad.IO.Class (MonadIO, liftIO)
@@ -908,7 +912,7 @@ makePong namespace mid to from =
 
 data ClientOrPeer = IsClient | IsPeer
 
-xmppInbound :: Server SockAddr ConnectionData releaseKey XML.Event -- ^ XXX: unused
+xmppInbound :: ConnectionData
                 -> XMPPServerParameters -- ^ XXX: unused
                 -> (Text, IO Text, IO Text, TChan Stanza -> StanzaOrigin)
                 -> FlagCommand  -- ^ action to check whether the connection needs a ping (XXX: unused)
@@ -916,14 +920,16 @@ xmppInbound :: Server SockAddr ConnectionData releaseKey XML.Event -- ^ XXX: unu
                 -> TChan Stanza -- ^ channel used to send stanzas
                 -> TMVar ()     -- ^ mvar that is filled when the connection quits
                 -> ConduitM Event o IO ()
-xmppInbound sv xmpp (namespace,tellmyname,tellyourname,mkorigin) pingflag stanzas output donevar = doNestingXML $ do
+xmppInbound cdta xmpp (namespace,tellmyname,tellyourname,mkorigin) pingflag stanzas output donevar = 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
+    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
     fix $ \loop -> do
     -- liftIO . wlog $ "waiting for stanza."
     (chan,clsrs) <- liftIO . atomically $
@@ -1282,13 +1288,25 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas = do
     let lbl n = concat [ n
                        , Text.unpack (Text.drop 7 namespace)
                        , "."
-                       , show saddr ]
-    forkIO $ do myThreadId >>= flip labelThread (lbl "post-queue.")
+                       , case cdProfile cdta of
+                            _ | Right _ <- cdAddr cdta -> show saddr
+                            "."                        -> show saddr
+                            mytoxname                  -> show saddr {- TODO: remote tox peer name? -} ]
+
+    forkIO $ do myThreadId >>= flip labelThread (lbl "xmpp-post.")
+                -- This thread handles messages after they are pulled out of
+                -- the slots-queue.  Hence, xmpp-post, for post- slots-queue.
+
+                -- Read all slots-queued XML events or stanzas and yield them
+                -- upstream.  This should continue until the connection is
+                -- closed.
                 (greet_src >> slot_src) $$ snk
+
+                -- Connection is now closed.  Here we handle any unsent stanzas.
                 last <- atomically $ readTVar lastStanza
                 es <- while (atomically . fmap not $ Slotted.isEmpty slots)
                             (atomically . Slotted.pull $ slots)
-                let es' = mapMaybe metadata es
+                let es' = mapMaybe metadata es -- We only care about full stanzas.
                     metadata (Left s) = Just s
                     metadata _        = Nothing
                 -- TODO: Issuing RecipientUnavailable for all errors is a presence leak
@@ -1304,17 +1322,21 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas = do
                             xmppDeliverMessage xmpp (wlog $ "discarded error delivery fail") replystanza
                     notError s = case stanzaType s of
                                     Error {} -> False
-                                    _ -> True
+                                    _        -> 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: " ++ (lbl "")
+                wlog $ "end xmpp-post fork: " ++ (lbl "")
 
     output <- atomically newTChan
     hacks <- atomically $ newTVar Map.empty
     msgids <- atomically $ newTVar []
     forkIO $ do
+        -- Here is the pre- slots-queue thread which handles messages as they
+        -- arrive and assigns slots to them if that is appropriate.
+
         -- mapM_ (atomically . Slotted.push slots Nothing) greetPeer
-        myThreadId >>= flip labelThread (lbl "pre-queue.")
+        myThreadId >>= flip labelThread (lbl "xmpp-pre.")
+
         verbosity <- xmppVerbosity xmpp
         fix $ \loop -> do
             what <- atomically $ foldr1 orElse
@@ -1385,11 +1407,11 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas = do
                 ,readTMVar rdone >> return (return ())
                 ]
             what
-        wlog $ "end pre-queue fork: " ++ show (lbl "")
+        wlog $ "end xmpp-pre fork: " ++ show (lbl "")
     forkIO $ do
         myThreadId >>= flip labelThread (lbl "reader.")
         -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show)
-        src $$ xmppInbound sv xmpp clientOrServer pingflag stanzas output rdone
+        src $$ xmppInbound cdta xmpp clientOrServer pingflag stanzas output rdone
         atomically $ putTMVar rdone ()
         wlog $ "end reader fork: " ++ lbl ""
     return output
@@ -1413,20 +1435,48 @@ peerKey bind_addr sock = do
         if c then getPeerName sock -- addr is normally socketName
              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
+    let peerport = fromIntegral $ fromMaybe 5269 $ do
+                        p <- bind_addr >>= sockAddrPort
+                        guard (p /= 0) -- Make sure we never use port 0 because it is used
+                                       -- to distinguish fake address connection keys.
+                        return p
+    rname <- atomically $ newTVar Nothing
     return $ ( raddr `withPort` peerport
-             , ConnectionData { cdAddr    = Left (Local laddr)
-                              , cdType    = XMPP
-                              , cdProfile = "." } )
+             , ConnectionData { cdAddr       = Left (Local laddr)
+                              , cdType       = XMPP
+                              , cdProfile    = "."
+                              , cdRemoteName = rname } )
 
 clientKey :: SocketLike sock => sock -> IO (SockAddr,ConnectionData)
 clientKey sock = do
     laddr <- getSocketName sock
     raddr <- getPeerName sock
+    when (Just 0 == sockAddrPort laddr) $ do
+        dput XMan $ unwords [ "BUG: XMPP Client"
+                            , show (laddr,raddr)
+                            , "is using port zero.  This could interfere"
+                            , "with Tox peer sessions." ]
+    rname <- atomically $ newTVar Nothing
     return $ ( laddr
-             , ConnectionData { cdAddr    = Right (Remote raddr)
-                              , cdType    = XMPP
-                              , cdProfile = "." } )
+             , ConnectionData { cdAddr       = Right (Remote raddr)
+                              , cdType       = XMPP
+                              , cdProfile    = "."
+                              , cdRemoteName = rname } )
+
+
+data Uniq24 = Uniq24 !Word64 !Word64 !Word64
+ deriving (Eq,Ord,Show)
+
+uniqueAsKey :: Uniq24 -> SockAddr
+uniqueAsKey (Uniq24 x y z) = SockAddrInet6 (fromIntegral 0) a bcde f
+ where
+    a = fromIntegral (x `shiftR` 32)
+    b = fromIntegral x
+    c = fromIntegral (y `shiftR` 32)
+    d = fromIntegral y
+    e = fromIntegral (z `shiftR` 32)
+    f = fromIntegral z
+    bcde = (b,c,d,e)
 
 xmlifyRosterItems :: Monad m => Set Text -> Text -> Set Text -> ConduitM i Event m ()
 xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set)
@@ -1840,9 +1890,13 @@ data ConnectionData = ConnectionData
     , cdProfile :: Text -- Currently ignored for clients.  Instead, see
                         -- 'clientProfile' field of 'ClientState'.
                         --
-                        -- For peers: "." for XMPP, otherwise the ".tox" hostname.
+                        -- For peers: "." for XMPP, otherwise the ".tox" hostname
+                        --  of this local node.
+
+      -- Initially Nothing, when the remote end identifies itself by a given name,
+      -- the result will be stored here.
+    , cdRemoteName :: TVar (Maybe Text)
     }
-    deriving (Eq,Ord,Show)
 
 addrToPeerKey :: Remote SockAddr -> PeerAddress
 addrToPeerKey (Remote raddr) = PeerAddress raddr