From 0a4d745e1f08c7c7a89f8c79ffb90170c13d2c88 Mon Sep 17 00:00:00 2001 From: joe Date: Sat, 15 Mar 2014 19:24:15 -0400 Subject: notify remote peers of utmp presences --- xmppServer.hs | 69 ++++++++++++++++++++++------------------------------------- 1 file changed, 25 insertions(+), 44 deletions(-) (limited to 'xmppServer.hs') diff --git a/xmppServer.hs b/xmppServer.hs index d5ad7c6a..1ab36cd6 100644 --- a/xmppServer.hs +++ b/xmppServer.hs @@ -37,6 +37,7 @@ import LocalPeerCred import XMPPServer import PeerResolve import ConsoleWriter +import ClientState type UserName = Text type ResourceName = Text @@ -74,28 +75,6 @@ localJID user resource = do hostname <- textHostName return $ user <> "@" <> hostname <> "/" <> resource -cf_available :: Int8 -cf_available = 0x1 -cf_interested :: Int8 -cf_interested = 0x2 - -data ClientState = ClientState - { clientResource :: Text - , clientUser :: Text - , clientPid :: Maybe ProcessID - , clientStatus :: TVar (Maybe Stanza) - , clientFlags :: TVar Int8 - } - --- | True if the client has sent an initial presence -clientIsAvailable c = do - flgs <- readTVar (clientFlags c) - return $ flgs .&. cf_available /= 0 - --- | True if the client has requested a roster -clientIsInterested c = do - flgs <- readTVar (clientFlags c) - return $ flgs .&. cf_interested /= 0 data LocalPresence = LocalPresence { networkClients :: Map ConnectionKey ClientState @@ -130,7 +109,7 @@ pcIsEmpty pc = Map.null (networkClients pc) data PresenceState = PresenceState { clients :: TVar (Map ConnectionKey ClientState) , clientsByUser :: TVar (Map Text LocalPresence) - , remotesByPeer :: TVar (Map (Maybe ConnectionKey) + , remotesByPeer :: TVar (Map ConnectionKey (Map UserName RemotePresence)) , associatedPeers :: TVar (Map SockAddr ()) @@ -326,13 +305,13 @@ eofConn state k = do jids <- atomically $ do rbp <- readTVar (remotesByPeer state) return $ do - umap <- maybeToList $ Map.lookup (Just k) rbp + umap <- maybeToList $ Map.lookup k rbp (u,rp) <- Map.toList umap r <- Map.keys (resources rp) return $ unsplitJID (Just u, h, Just r) forM_ jids $ \jid -> do stanza <- makePresenceStanza "jabber:client" (Just jid) Offline - informPeerPresence state (Just k) stanza + informPeerPresence state k stanza {- rewriteJIDForClient1:: Text -> IO (Maybe ((Maybe Text,Text,Maybe Text),SockAddr)) @@ -480,10 +459,13 @@ deliverMessage state fail msg = setClientFlag state k flag = - atomically $ do - cmap <- readTVar (clients state) - flip (maybe $ return ()) (Map.lookup k cmap) $ \client -> do - modifyTVar' (clientFlags client) (\flgs -> flgs .|. flag) + atomically $ do + cmap <- readTVar (clients state) + flip (maybe $ return ()) (Map.lookup k cmap) $ \client -> do + setClientFlag0 client flag + +setClientFlag0 client flag = + modifyTVar' (clientFlags client) (\flgs -> flgs .|. flag) informSentRoster state k = do setClientFlag state k cf_interested @@ -503,16 +485,16 @@ clientJID con client = unsplitJID ( Just $ clientUser client -- Note that a full JID from address will be added to the -- stanza if it is not present. informClientPresence state k stanza = do - dup <- cloneStanza stanza - atomically $ do - mb <- fmap (Map.lookup k) $ readTVar (clients state) - flip (maybe $ return ()) mb $ \cstate -> do - writeTVar (clientStatus cstate) $ Just dup forClient state k (return ()) $ \client -> do + informClientPresence0 state (Just k) client stanza + +informClientPresence0 state mbk client stanza = do + dup <- cloneStanza stanza + atomically $ writeTVar (clientStatus client) $ Just dup is_avail <- atomically $ clientIsAvailable client when (not is_avail) $ do - setClientFlag state k cf_available - sendCachedPresence state k + atomically $ setClientFlag0 client cf_available + maybe (return ()) (sendCachedPresence state) mbk addrs <- subscribedPeers (clientUser client) ktc <- atomically $ readTVar (keyToChan state) let connected = mapMaybe (flip Map.lookup ktc . PeerKey) addrs @@ -579,7 +561,7 @@ informPeerPresence state k stanza = do is_avail <- atomically $ clientIsAvailable client when is_avail $ do putStrLn $ "reversing for client: " ++ show from - froms <- flip (maybe $ return [from]) k . const $ do + froms <- do -- flip (maybe $ return [from]) k . const $ do let ClientKey laddr = ck (_,trip) <- multiplyJIDForClient laddr from return (map unsplitJID trip) @@ -649,16 +631,15 @@ sendCachedPresence state k = do jids <- configText ConfigFiles.getBuddies (clientUser client) let hosts = map ((\(_,h,_)->h) . splitJID) jids addrs <- resolveAllPeers hosts - let onlines = rbp `Map.intersection` (Map.insert Nothing () -- send console presences - $ Map.mapKeys (Just . PeerKey) addrs) + let onlines = rbp `Map.intersection` Map.mapKeys PeerKey addrs ClientKey laddr = k mcon <- atomically $ do ktc <- readTVar (keyToChan state) return $ Map.lookup k ktc flip (maybe $ return ()) mcon $ \con -> do - me <- textHostName + -- me <- textHostName forM_ (Map.toList onlines) $ \(pk, umap) -> do forM_ (Map.toList umap) $ \(user,rp) -> do - let h = maybe me peerKeyToText pk + let h = peerKeyToText pk forM_ (Map.toList $ resources rp) $ \(resource,stanza) -> do let jid = unsplitJID (Just user,h,Just resource) (mine,js) <- multiplyJIDForClient laddr jid @@ -1002,7 +983,7 @@ main = runResourceT $ do , xmppSubscribeToRoster = informSentRoster state , xmppDeliverMessage = deliverMessage state , xmppInformClientPresence = informClientPresence state - , xmppInformPeerPresence = \k -> informPeerPresence state (Just k) + , xmppInformPeerPresence = informPeerPresence state , xmppAnswerProbe = \k stanza chan -> answerProbe state (stanzaTo stanza) k chan , xmppClientSubscriptionRequest = clientSubscriptionRequest state , xmppPeerSubscriptionRequest = peerSubscriptionRequest state @@ -1020,8 +1001,8 @@ main = runResourceT $ do console <- atomically $ dupTChan (cwPresenceChan $ consoleWriter state) fix $ \loop -> do what <- atomically - $ orElse (do stanza <- readTChan console - return $ do informPeerPresence state Nothing stanza + $ orElse (do (client,stanza) <- readTChan console + return $ do informClientPresence0 state Nothing client stanza loop) (do readTMVar quitVar return $ return ()) -- cgit v1.2.3