xmpp: cache stream name

2 files changed, 125 insertions, 34 deletions

diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index 4f0deb32..fad87aeb 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -475,19 +475,49 @@ delclient k mlp = 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
+            h <- case cdType cdta of
+                -- TODO: This should be cached (perhaps by rewriteJIDForClient?) so that we
+                -- guarantee that the OFFLINE message matches the ONLINE message.
+                -- For now, we reverse-resolve the peer key.
+                XMPP -> -- For XMPP peers, informPeerPresence expects a textual
+                        -- representation of the IP address to reverse-resolve.
+                        return $ peerKeyToText k
+                Tox  -> do
+                    -- For Tox peers, informPeerPresence expects the actual hostname
+                    -- so we will use the one that the peer told us at greeting time.
+                    m <- atomically $ swapTVar (cdRemoteName cdta) Nothing
+                    case m of
+                        Nothing -> do
+                            dput XJabber $ "BUG: Tox peer didn't inform us of its name."
+                            -- The following fallback behavior is probably wrong.
+                            return $ peerKeyToText k
+                        Just toxname -> return toxname
+            -- ioToSource terminated.
+            --
+            -- dhtd: Network.Socket.getAddrInfo
+            --   (called with preferred socket type/protocol: AddrInfo
+            --      { addrFlags = [AI_NUMERICHOST], addrFamily = AF_UNSPEC
+            --      , addrSocketType = NoSocketType, addrProtocol = 0
+            --      , addrAddress = <assumed to be undefined>
+            --      , addrCanonName = <assumed to be undefined>}
+            --      , host name: Just "DdhbLjiwaV0GAiGKgesNPbvj2TbhrBHEWEEc5icfvQN.tox"
+            --      , service name: Just "0")
+            --      : does not exist (Name or service not known)
+
             jids <- atomically $ do
                 rbp <- readTVar (remotesByPeer state)
                 return $ do
                     umap <- maybeToList $ Map.lookup k rbp
                     (u,rp) <- Map.toList umap
                     r <- Map.keys (resources rp)
-                    return $ unsplitJID (Just u, h, Just r)
+                    let excludeEmpty "" = Nothing
+                        excludeEmpty x  = Just x
+                    return $ unsplitJID (excludeEmpty u, h, excludeEmpty r)
+            -- EOF PEER PeerAddress [d768:82dd:3e86:a6ba:8fb3:6f9c:6327:75d8%4236342772]:0:
+            --   ["@[d768:82dd:3e86:a6ba:8fb3:6f9c:6327:75d8%4236342772]/"]
+            -- dput XJabber $ "EOF PEER "++show k++": "++show jids
             forM_ jids $ \jid -> do
             stanza <- makePresenceStanza "jabber:client" (Just jid) Offline
             informPeerPresence state k stanza
@@ -502,6 +532,9 @@ eofConn state saddr cdta = do
             atomically $ do
                 modifyTVar' (clientsByUser    state) $ Map.alter (delclient k) (clientUser    client)
                 modifyTVar' (clientsByProfile state) $ Map.alter (delclient k) (clientProfile client)
+    atomically $ case classifyConnection saddr cdta of
+                    Left  (pkey,_) -> modifyTVar' (pkeyToChan state) $ Map.delete pkey
+                    Right (ckey,_) -> modifyTVar' (ckeyToChan state) $ Map.delete ckey
 
 {-
 parseRemoteAddress :: Text -> IO (Maybe (Remote SockAddr))
@@ -594,8 +627,9 @@ deliverMessage state fail msg =
         -- Case 1.  Client -> Peer
         mto <- join $ atomically $ do
             mclient <- Map.lookup senderk <$> readTVar (clients state)
-            return
-              $ fromMaybe -- Resolve XMPP peer.
+            return $ do
+              dput XJabber $ "deliverMessage: to="++show (stanzaTo msg,fmap clientProfile mclient)
+              fromMaybe -- Resolve XMPP peer.
                           (fmap join $ mapM rewriteJIDForPeer (stanzaTo msg))
                 $ do
                      client <- mclient
@@ -603,6 +637,7 @@ deliverMessage state fail msg =
                      let (mu,th,rsc) = splitJID to
                      (toxman,me,_) <- weAreTox state client th
                      return $ do
+                         dput XJabber $ "deliverMessage: weAreTox="++show me
                          -- In case the client sends us a lower-cased version of the base64
                          -- tox key hostname, we resolve it by comparing it with roster entries.
                          xs <- getBuddiesAndSolicited state (clientProfile client) $ \case
@@ -637,7 +672,7 @@ deliverMessage state fail msg =
                       fail)
                 $ Map.lookup senderk pchans
             <&> \(Conn { connChan = sender_chan
-                       , auxData  = ConnectionData (Left laddr) ctyp cprof }) -> do
+                       , auxData  = ConnectionData (Left laddr) ctyp cprof _ }) -> do
         fromMaybe (do dput XJabber $ "Message missing \"to\" attribute."
                       fail)
                 $ (stanzaTo msg) <&> \to -> do
@@ -777,7 +812,7 @@ informPeerPresence state k stanza = do
     let (muser0,h,mresource0) = splitJID from
         -- We'll allow the case that user and resource are simultaneously
         -- absent.  They will be stored in the remotesByPeer map using the
-        -- empty string.  This is to accomodate the tox protocol which didn't
+        -- empty string.  This is to accommodate the tox protocol which didn't
         -- anticipate a single peer would have multiple users or front-ends.
         (muser,mresource) = case (muser0,mresource0) of
             (Nothing,Nothing) -> (Just "", Just "")
@@ -826,14 +861,16 @@ informPeerPresence state k stanza = do
     (ctyp,cprof) <- atomically $ do
         mconn <- Map.lookup k <$> readTVar (pkeyToChan state)
         return $ fromMaybe (XMPP,".") $ do
-            ConnectionData _ ctyp cprof <- auxData <$> mconn
+            ConnectionData _ ctyp cprof _ <- auxData <$> mconn
             return (ctyp,cprof)
     forM_ clients $ \(ck,con,client) -> do
         -- (TODO: appropriately authorized clients only.)
         -- For now, all "available" clients (available = sent initial presence)
         is_avail <- atomically $ clientIsAvailable client
         when is_avail $ do
-        dput XJabber $ "reversing for client: " ++ show from
+        -- reversing for client: ("DdhbLjiwaV0GAiGKgesNPbvj2TbhrBHEWEEc5icfvQN.tox"
+        --                       ,XMPP,"OrjBG.GyWuQhGc1pb0KssgmYAocohFh35Vx8mREC9Nu.tox",".")
+        dput XJabber $ "reversing for client: " ++ show (from,ctyp,clientProfile client,cprof)
         froms <- case ctyp of
             Tox | clientProfile client == cprof -> return [from]
             _ -> do -- flip (maybe $ return [from]) k . const $ do
@@ -1030,7 +1067,7 @@ clientSubscriptionRequest :: PresenceState -> IO () -> ClientAddress -> Stanza -
 clientSubscriptionRequest state fail k stanza chan = do
     forClient state k fail $ \client -> do
     fromMaybe fail $ (splitJID <$> stanzaTo stanza) <&> \(mu,h,_) -> do
-    dput XJabber $ "Forwarding solictation to peer"
+    dput XJabber $ "Forwarding solicitation to peer"
     let to0   = unsplitJID (mu,h,Nothing) -- deleted resource
         cuser = clientUser client
         cprof = clientProfile client
@@ -1166,7 +1203,7 @@ 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 (Left laddr) ctyp profile _ } -> do
     (mine,totup) <- case (ctyp,profile) of
         (Tox,p) -> let (u,h,r) = splitJID to
                    in return ( h == p, (u,h,r) )
@@ -1314,7 +1351,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 profile}) -> do
+                   , auxData =ConnectionData (Left laddr) ctyp profile _ }) -> do
     (from_u,from_h,_) <- case ctyp of
         Tox  -> return $ splitJID from
         XMPP -> snd <$> rewriteJIDForClient laddr from []
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