From 23aff0ea436480ca65a9141f1498e6b53007f45b Mon Sep 17 00:00:00 2001 From: joe Date: Sun, 9 Mar 2014 16:56:11 -0400 Subject: bug fixes --- xmppServer.hs | 90 ++++++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 62 insertions(+), 28 deletions(-) (limited to 'xmppServer.hs') diff --git a/xmppServer.hs b/xmppServer.hs index 74adc620..5771510a 100644 --- a/xmppServer.hs +++ b/xmppServer.hs @@ -15,7 +15,7 @@ import Network.Socket , SockAddr(..) ) import System.Endian (fromBE32) -import Data.List (nub, (\\) ) +import Data.List (nub, (\\), intersect ) import Data.Monoid ( (<>) ) import qualified Data.Text as Text import qualified Data.Text.IO as Text @@ -86,14 +86,18 @@ data ClientState = ClientState , clientUser :: Text , clientPid :: Maybe ProcessID , clientStatus :: TVar (Maybe Stanza) - , clientFlags :: Int8 + , clientFlags :: TVar Int8 } -- | True if the client has sent an initial presence -clientIsAvailable c = clientFlags c .&. cf_available /= 0 +clientIsAvailable c = do + flgs <- readTVar (clientFlags c) + return $ flgs .&. cf_available /= 0 -- | True if the client has requested a roster -clientIsInterested c = clientFlags c .&. cf_interested /= 0 +clientIsInterested c = do + flgs <- readTVar (clientFlags c) + return $ flgs .&. cf_interested /= 0 data LocalPresence = LocalPresence { networkClients :: Map ConnectionKey ClientState @@ -171,11 +175,12 @@ chooseResourceName state k addr desired = do (mtty,pid) <- getTTYandPID muid user <- getJabberUserForId muid status <- atomically $ newTVar Nothing + flgs <- atomically $ newTVar 0 let client = ClientState { clientResource = maybe "fallback" id mtty , clientUser = user , clientPid = pid , clientStatus = status - , clientFlags = 0 } + , clientFlags = flgs } atomically $ do modifyTVar' (clients state) $ Map.insert k client @@ -310,12 +315,22 @@ newConn state k addr outchan = do when (isPeerKey k) $ sendProbesAndSolicitations state k addr outchan +delclient k mlp = do + lp <- mlp + let nc = Map.delete k $ networkClients lp + guard $ not (Map.null nc) + return $ lp { networkClients = nc } + eofConn state k = do atomically $ modifyTVar' (keyToChan state) $ Map.delete k case k of ClientKey {} -> do + forClient state k (return ()) $ \client -> do stanza <- makePresenceStanza "jabber:server" Nothing Offline informClientPresence state k stanza + atomically $ do + modifyTVar' (clientsByUser state) + $ Map.alter (delclient k) (clientUser client) PeerKey {} -> do let h = peerKeyToText k jids <- atomically $ do @@ -465,12 +480,13 @@ deliverMessage state fail msg = setClientFlag state k flag = - atomically $ modifyTVar' (clients state) - $ Map.adjust - (\c -> c { clientFlags = clientFlags c .|. flag }) - k + atomically $ do + cmap <- readTVar (clients state) + flip (maybe $ return ()) (Map.lookup k cmap) $ \client -> do + modifyTVar' (clientFlags client) (\flgs -> flgs .|. flag) -informSentRoster state k = setClientFlag state k cf_interested +informSentRoster state k = do + setClientFlag state k cf_interested subscribedPeers user = do @@ -493,7 +509,8 @@ informClientPresence state k stanza = do flip (maybe $ return ()) mb $ \cstate -> do writeTVar (clientStatus cstate) $ Just dup forClient state k (return ()) $ \client -> do - when (not $ clientIsAvailable client) $ do + is_avail <- atomically $ clientIsAvailable client + when (not is_avail) $ do setClientFlag state k cf_available sendCachedPresence state k addrs <- subscribedPeers (clientUser client) @@ -546,7 +563,8 @@ informPeerPresence state k stanza = do forM_ clients $ \(ck,con,client) -> do -- (TODO: appropriately authorized clients only.) -- For now, all "available" clients (available = sent initial presence) - when (clientIsAvailable client) $ do + is_avail <- atomically $ clientIsAvailable client + when is_avail $ do froms <- do let ClientKey laddr = ck (_,trip) <- multiplyJIDForClient laddr from @@ -557,11 +575,11 @@ informPeerPresence state k stanza = do sendModifiedStanzaToClient (dup { stanzaFrom=Just from' }) (connChan con) -answerProbe state k stanza chan = do +answerProbe state mto k chan = do -- putStrLn $ "answerProbe! " ++ show (stanzaType stanza) ktc <- atomically $ readTVar (keyToChan state) muser <- runTraversableT $ do - to <- liftT $ stanzaTo stanza + to <- liftT $ mto conn <- liftT $ Map.lookup k ktc let (mu,h,_) = splitJID to -- TODO: currently resource-id is ignored on presence -- probes. Is this correct? Check the spec. @@ -665,6 +683,11 @@ clientSubscriptionRequest state fail k stanza chan = do if null addrs then fail else do -- add to-address to from's solicited addToRosterFile ConfigFiles.modifySolicited (clientUser client) to addrs + removeFromRosterFile ConfigFiles.modifyBuddies (clientUser client) to addrs + resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers (clientUser client) + let is_subscribed = not . null $ intersect (map ((mu,).PeerKey) addrs) resolved_subs + -- subscribers: "from" + -- buddies: "to" (ktc,ap) <- atomically $ liftM2 (,) (readTVar $ keyToChan state) @@ -677,7 +700,11 @@ clientSubscriptionRequest state fail k stanza chan = do chans <- clientCons state ktc (clientUser client) forM_ chans $ \( Conn { connChan=chan }, client ) -> do -- roster update ask="subscribe" - update <- makeRosterUpdate cjid to ("ask","subscribe") + update <- makeRosterUpdate cjid to + [ ("ask","subscribe") + , if is_subscribed then ("subscription","from") + else ("subscription","none") + ] sendModifiedStanzaToClient update chan _ -> return () @@ -700,6 +727,7 @@ clientSubscriptionRequest state fail k stanza chan = do -- Add peer if we are not already associated ... sv <- atomically $ takeTMVar $ server state addPeer sv (head addrs) + atomically $ putTMVar (server state) sv resolvedFromRoster @@ -755,6 +783,7 @@ peerSubscriptionRequest state fail k stanza chan = do -- (note: swapping to and from for reply) reply <- makeInformSubscription "jabber:server" to from is_wanted sendModifiedStanzaToPeer reply chan + answerProbe state (Just to) k chan else do -- TODO: if peer-connection is to self, then auto-approve local user. @@ -797,7 +826,7 @@ clientInformSubscription state fail k stanza = do addrs <- resolvePeer h -- remove from pending buds <- resolvedFromRoster ConfigFiles.getBuddies (clientUser client) - let is_buddy = not . null $ map ((mu,) . PeerKey) addrs \\ buds + let is_buddy = not . null $ map ((mu,) . PeerKey) addrs `intersect` buds removeFromRosterFile ConfigFiles.modifyPending (clientUser client) to addrs let (relationship,addf,remf) = case stanzaType stanza of @@ -813,20 +842,27 @@ clientInformSubscription state fail k stanza = do addToRosterFile addf (clientUser client) to addrs removeFromRosterFile remf (clientUser client) to addrs + do + cbu <- atomically $ readTVar (clientsByUser state) + putStrLn $ "cbu = " ++ show (fmap (fmap clientPid . networkClients) cbu) + -- send roster update to clients (clients,ktc) <- atomically $ do cbu <- readTVar (clientsByUser state) - let mlp = mu >>= flip Map.lookup cbu + let mlp = Map.lookup (clientUser client) cbu let cs = maybe [] (Map.toList . networkClients) mlp ktc <- readTVar (keyToChan state) return (cs,ktc) forM_ clients $ \(ck, client) -> do - when (clientIsInterested client) $ do + is_intereseted <- atomically $ clientIsInterested client + putStrLn $ "clientIsInterested: "++show is_intereseted + is_intereseted <- atomically $ clientIsInterested client + when is_intereseted $ do flip (maybe $ return ()) (Map.lookup ck ktc) $ \con -> do hostname <- textHostName -- TODO: Should cjid include the resource? let cjid = unsplitJID (mu, hostname, Nothing) - update <- makeRosterUpdate cjid to relationship + update <- makeRosterUpdate cjid to [relationship] sendModifiedStanzaToClient update (connChan con) -- notify peer @@ -839,6 +875,7 @@ clientInformSubscription state fail k stanza = do sendModifiedStanzaToPeer (dup { stanzaTo = Just $ to' , stanzaFrom = Just from }) (connChan con) + answerProbe state (Just from) pk (connChan con) peerInformSubscription state fail k stanza = do putStrLn $ "TODO: peerInformSubscription" @@ -858,7 +895,7 @@ peerInformSubscription state fail k stanza = do addrs <- resolvePeer from_h was_solicited <- removeFromRosterFile ConfigFiles.modifySolicited user from'' addrs subs <- resolvedFromRoster ConfigFiles.getSubscribers user - let is_sub = not . null $ map ((from_u,) . PeerKey) addrs \\ subs + let is_sub = not . null $ map ((from_u,) . PeerKey) addrs `intersect` subs let (relationship,addf,remf) = case stanzaType stanza of PresenceInformSubscription True -> @@ -873,20 +910,17 @@ peerInformSubscription state fail k stanza = do addToRosterFile addf user from'' addrs removeFromRosterFile remf user from'' addrs - ktc <- atomically $ readTVar (keyToChan state) - flip (maybe fail) (Map.lookup k ktc) - $ \Conn { auxAddr=laddr } -> do hostname <- textHostName let to' = unsplitJID (Just user, hostname, Nothing) - (_,fromtup) <- rewriteJIDForClient laddr from chans <- clientCons state ktc user forM_ chans $ \(Conn { connChan=chan }, client) -> do - update <- makeRosterUpdate to' from relationship - when (clientIsInterested client) $ do + update <- makeRosterUpdate to' from'' [relationship] + is_intereseted <- atomically $ clientIsInterested client + when is_intereseted $ do sendModifiedStanzaToClient update chan -- TODO: interested/availabe clients only? dup <- cloneStanza stanza - sendModifiedStanzaToClient dup { stanzaFrom = Just $ unsplitJID fromtup + sendModifiedStanzaToClient dup { stanzaFrom = Just $ from'' , stanzaTo = Just to' } chan @@ -924,7 +958,7 @@ main = runResourceT $ do , xmppDeliverMessage = deliverMessage state , xmppInformClientPresence = informClientPresence state , xmppInformPeerPresence = informPeerPresence state - , xmppAnswerProbe = answerProbe state + , xmppAnswerProbe = \k stanza chan -> answerProbe state (stanzaTo stanza) k chan , xmppClientSubscriptionRequest = clientSubscriptionRequest state , xmppPeerSubscriptionRequest = peerSubscriptionRequest state , xmppClientInformSubscription = clientInformSubscription state -- cgit v1.2.3