From 238887849791fe045ee87f047d5e622b5f371333 Mon Sep 17 00:00:00 2001 From: joe Date: Thu, 9 Nov 2017 19:55:09 -0500 Subject: Factored out Presence.hs from main module xmppServer.hs. --- xmppServer.hs | 1042 +-------------------------------------------------------- 1 file changed, 4 insertions(+), 1038 deletions(-) (limited to 'xmppServer.hs') diff --git a/xmppServer.hs b/xmppServer.hs index 803b4324..01246f64 100644 --- a/xmppServer.hs +++ b/xmppServer.hs @@ -44,1002 +44,7 @@ import XMPPServer import PeerResolve import ConsoleWriter import ClientState - -type UserName = Text -type ResourceName = Text - -unsplitJID :: (Maybe UserName,Text,Maybe ResourceName) -> Text -unsplitJID (n,h,r) = username <> h <> resource - where - username = maybe "" (<>"@") n - resource = maybe "" ("/"<>) r - -splitJID :: Text -> (Maybe UserName,Text,Maybe ResourceName) -splitJID bjid = - let xs = splitAll '@' bjid - ys = splitAll '/' (last xs) - splitAll c bjid = take 1 xs0 ++ map (Text.drop 1) (drop 1 xs0) - where xs0 = Text.groupBy (\x y-> y/=c) bjid - server = head ys - name = case xs of - (n:s:_) -> Just n - (s:_) -> Nothing - rsrc = case ys of - (s:_:_) -> Just $ last ys - _ -> Nothing - in (name,server,rsrc) - -isPeerKey :: ConnectionKey -> Bool -isPeerKey k = case k of { PeerKey {} -> True ; _ -> False } - -isClientKey :: ConnectionKey -> Bool -isClientKey k = case k of { ClientKey {} -> True ; _ -> False } - -textHostName :: IO Text -textHostName = fmap Text.pack BSD.getHostName - -localJID :: Text -> Text -> IO Text -localJID user resource = do - hostname <- textHostName - return $ user <> "@" <> hostname <> "/" <> resource - - -data LocalPresence = LocalPresence - { networkClients :: Map ConnectionKey ClientState - -- TODO: loginClients - } - -data RemotePresence = RemotePresence - { resources :: Map Text Stanza - -- , localSubscribers :: Map Text () - -- ^ subset of clientsByUser who should be - -- notified about this presence. - } - - - -pcSingletonNetworkClient :: ConnectionKey - -> ClientState -> LocalPresence -pcSingletonNetworkClient key client = - LocalPresence - { networkClients = Map.singleton key client - } - -pcInsertNetworkClient :: ConnectionKey -> ClientState -> LocalPresence -> LocalPresence -pcInsertNetworkClient key client pc = - pc { networkClients = Map.insert key client (networkClients pc) } - -pcRemoveNewtworkClient :: ConnectionKey - -> LocalPresence -> Maybe LocalPresence -pcRemoveNewtworkClient key pc = if pcIsEmpty pc' then Nothing - else Just pc' - where - pc' = pc { networkClients = Map.delete key (networkClients pc) } - -pcIsEmpty :: LocalPresence -> Bool -pcIsEmpty pc = Map.null (networkClients pc) - - -data PresenceState = PresenceState - { clients :: TVar (Map ConnectionKey ClientState) - , clientsByUser :: TVar (Map Text LocalPresence) - , remotesByPeer :: TVar (Map ConnectionKey - (Map UserName - RemotePresence)) - , associatedPeers :: TVar (Map SockAddr ()) - , server :: TMVar XMPPServer - , keyToChan :: TVar (Map ConnectionKey Conn) - , consoleWriter :: ConsoleWriter - } - - - -getConsolePids :: PresenceState -> IO [(Text,ProcessID)] -getConsolePids state = do - us <- UTmp.users - return $ map (\(_,tty,pid)->(lazyByteStringToText tty,pid)) us - -lazyByteStringToText :: L.ByteString -> Text -lazyByteStringToText = (foldr1 (<>) . map Text.decodeUtf8 . L.toChunks) - -textToLazyByteString :: Text -> L.ByteString -textToLazyByteString s = L.fromChunks [Text.encodeUtf8 s] - -identifyTTY' :: [(Text, ProcessID)] - -> System.Posix.Types.UserID - -> L.ByteString - -> IO (Maybe Text, Maybe System.Posix.Types.CPid) -identifyTTY' ttypids uid inode = ttypid - where ttypids' = map (\(tty,pid)->(L.fromChunks [Text.encodeUtf8 tty], pid)) ttypids - ttypid = fmap textify $ identifyTTY ttypids' uid inode - textify (tty,pid) = (fmap lazyByteStringToText tty, pid) - -chooseResourceName :: PresenceState - -> ConnectionKey -> SockAddr -> t -> IO Text -chooseResourceName state k addr desired = do - muid <- getLocalPeerCred' addr - (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 = flgs } - - do -- forward-lookup of the buddies so that it is cached for reversing. - buds <- configText ConfigFiles.getBuddies (clientUser client) - forM_ buds $ \bud -> do - let (_,h,_) = splitJID bud - forkIO $ void $ resolvePeer h - - atomically $ do - modifyTVar' (clients state) $ Map.insert k client - modifyTVar' (clientsByUser state) $ flip Map.alter (clientUser client) - $ \mb -> Just $ maybe (pcSingletonNetworkClient k client) - (pcInsertNetworkClient k client) - mb - - localJID (clientUser client) (clientResource client) - - where - getTTYandPID muid = do - -- us <- fmap (map (second fst) . Map.toList) . readTVarIO $ activeUsers state - ttypids <- getConsolePids state - -- let tailOf3 ((_,a),b) = (a,b) - (t,pid) <- case muid of - Just (uid,inode) -> identifyTTY' ttypids uid inode - Nothing -> return (Nothing,Nothing) - let rsc = t `mplus` fmap ( ("pid."<>) . Text.pack . show ) pid - return (rsc,pid) - - getJabberUserForId muid = - maybe (return "nobody") - (\(uid,_) -> - handle (\(SomeException _) -> - return . (<> "uid.") . Text.pack . show $ uid) - $ do - user <- fmap userName $ getUserEntryForID uid - return (Text.pack user) - ) - muid - -forClient :: PresenceState - -> ConnectionKey -> IO b -> (ClientState -> IO b) -> IO b -forClient state k fallback f = do - mclient <- atomically $ do - cs <- readTVar (clients state) - return $ Map.lookup k cs - maybe fallback f mclient - -tellClientHisName :: PresenceState -> ConnectionKey -> IO Text -tellClientHisName state k = forClient state k fallback go - where - fallback = localJID "nobody" "fallback" - go client = localJID (clientUser client) (clientResource client) - -toMapUnit :: Ord k => [k] -> Map k () -toMapUnit xs = Map.fromList $ map (,()) xs - -resolveAllPeers :: [Text] -> IO (Map SockAddr ()) -resolveAllPeers hosts = fmap (toMapUnit . concat) $ Prelude.mapM (fmap (take 1) . resolvePeer) hosts - - -rosterGetStuff - :: (L.ByteString -> IO [L.ByteString]) - -> PresenceState -> ConnectionKey -> IO [Text] -rosterGetStuff what state k = forClient state k (return []) - $ \client -> do - jids <- configText what (clientUser client) - let hosts = map ((\(_,h,_)->h) . splitJID) jids - addrs <- resolveAllPeers hosts - peers <- atomically $ readTVar (associatedPeers state) - addrs <- return $ addrs `Map.difference` peers - sv <- atomically $ takeTMVar $ server state - -- Grok peers to associate with from the roster: - forM_ (Map.keys addrs) $ \addr -> do - putStrLn $ "new addr: "++show addr - addPeer sv addr - -- Update local set of associated peers - atomically $ do - writeTVar (associatedPeers state) (addrs `Map.union` peers) - putTMVar (server state) sv - return jids - -rosterGetBuddies :: PresenceState -> ConnectionKey -> IO [Text] -rosterGetBuddies state k = rosterGetStuff ConfigFiles.getBuddies state k - -rosterGetSolicited :: PresenceState -> ConnectionKey -> IO [Text] -rosterGetSolicited = rosterGetStuff ConfigFiles.getSolicited - -rosterGetOthers :: PresenceState -> ConnectionKey -> IO [Text] -rosterGetOthers = rosterGetStuff ConfigFiles.getOthers - -rosterGetSubscribers :: PresenceState -> ConnectionKey -> IO [Text] -rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers - -data Conn = Conn { connChan :: TChan Stanza - , auxAddr :: SockAddr } - -configText :: Functor f => - (L.ByteString -> f [L.ByteString]) -> Text -> f [Text] -configText what u = fmap (map lazyByteStringToText) - $ what (textToLazyByteString u) - -getBuddies' :: Text -> IO [Text] -getBuddies' = configText ConfigFiles.getBuddies -getSolicited' :: Text -> IO [Text] -getSolicited' = configText ConfigFiles.getSolicited - -sendProbesAndSolicitations :: PresenceState - -> ConnectionKey -> SockAddr -> TChan Stanza -> IO () -sendProbesAndSolicitations state k laddr chan = do - -- get all buddies & solicited matching k for all users - xs <- runTraversableT $ do - cbu <- lift $ atomically $ readTVar $ clientsByUser state - user <- liftT $ Map.keys cbu - (isbud,getter) <- liftT [(True ,getBuddies' ) - ,(False,getSolicited')] - bud <- liftMT $ getter user - let (u,h,r) = splitJID bud - addr <- liftMT $ nub `fmap` resolvePeer h - liftT $ guard (PeerKey addr == k) - -- Note: Earlier I was tempted to do all the IO - -- within the TraversableT monad. That apparently - -- is a bad idea. Perhaps due to laziness and an - -- unforced list? Instead, we will return a list - -- of (Bool,Text) for processing outside. - return (isbud,u,if isbud then "" else user) - -- XXX: The following O(n²) nub may be a little - -- too onerous. - forM_ (nub xs) $ \(isbud,u,user) -> do - let make = if isbud then presenceProbe - else presenceSolicitation - toh = peerKeyToText k - jid = unsplitJID (u,toh,Nothing) - me = addrToText laddr - from = if isbud then me -- probe from server - else -- solicitation from particular user - unsplitJID (Just user,me,Nothing) - stanza <- make from jid - -- send probes for buddies, solicitations for solicited. - putStrLn $ "probing "++show k++" for: " ++ show (isbud,jid) - atomically $ writeTChan chan stanza - -- reverse xs `seq` return () - -newConn :: PresenceState -> ConnectionKey -> SockAddr -> TChan Stanza -> IO () -newConn state k addr outchan = do - atomically $ modifyTVar' (keyToChan state) - $ Map.insert k Conn { connChan = outchan - , auxAddr = addr } - when (isPeerKey k) - $ sendProbesAndSolicitations state k addr outchan - -delclient :: (Alternative m, Monad m) => - ConnectionKey -> m LocalPresence -> m LocalPresence -delclient k mlp = do - lp <- mlp - let nc = Map.delete k $ networkClients lp - guard $ not (Map.null nc) - return $ lp { networkClients = nc } - -eofConn :: PresenceState -> ConnectionKey -> IO () -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 - 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) - forM_ jids $ \jid -> do - stanza <- makePresenceStanza "jabber:client" (Just jid) Offline - informPeerPresence state k stanza - -{- -rewriteJIDForClient1:: Text -> IO (Maybe ((Maybe Text,Text,Maybe Text),SockAddr)) -rewriteJIDForClient1 jid = do - let (n,h,r) = splitJID jid - maddr <- fmap listToMaybe $ resolvePeer h - flip (maybe $ return Nothing) maddr $ \addr -> do - h' <- peerKeyToResolvedName (PeerKey addr) - return $ Just ((n,h',r), addr) --} - --- | for example: 2001-db8-85a3-8d3-1319-8a2e-370-7348.ipv6-literal.net -ip6literal :: Text -> Text -ip6literal addr = Text.map dash addr <> ".ipv6-literal.net" - where - dash ':' = '-' - dash x = x - --- | The given address is taken to be the local address for the socket this JID --- came in on. The returned JID parts are suitable for unsplitJID to create a --- valid JID for communicating to a client. The returned Bool is True when the --- host part refers to this local host (i.e. it equals the given SockAddr). --- If there are multiple results, it will prefer one which is a member of the --- given list in the last argument. -rewriteJIDForClient :: SockAddr -> Text -> [Text] -> IO (Bool,(Maybe Text,Text,Maybe Text)) -rewriteJIDForClient laddr jid buds = do - let (n,h,r) = splitJID jid - maddr <- parseAddress (strip_brackets h) - flip (maybe $ return (False,(n,ip6literal h,r))) maddr $ \addr -> do - let mine = laddr `withPort` 0 == addr `withPort` 0 - h' <- if mine then textHostName - else peerKeyToResolvedName buds (PeerKey addr) - return (mine,(n,h',r)) - -sameAddress :: SockAddr -> SockAddr -> Bool -sameAddress laddr addr = laddr `withPort` 0 == addr `withPort` 0 - -peerKeyToResolvedName :: [Text] -> ConnectionKey -> IO Text -peerKeyToResolvedName buds k@(ClientKey { localAddress=addr }) = return "ErrorClIeNt1" -peerKeyToResolvedName buds pk = do - ns <- peerKeyToResolvedNames pk - let hs = map (\jid -> let (_,h,_)=splitJID jid in h) buds - ns' = sortBy (comparing $ not . flip elem hs) ns - return $ maybe (peerKeyToText pk) id (listToMaybe ns') - - -multiplyJIDForClient :: SockAddr -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)]) -multiplyJIDForClient laddr jid = do - let (n,h,r) = splitJID jid - maddr <- parseAddress (strip_brackets h) - flip (maybe $ return (False,[(n,ip6literal h,r)])) maddr $ \addr -> do - let mine = sameAddress laddr addr - names <- if mine then fmap (:[]) textHostName - else peerKeyToResolvedNames (PeerKey addr) - return (mine,map (\h' -> (n,h',r)) names) - - -addrTextToKey :: Text -> IO (Maybe ConnectionKey) -addrTextToKey h = do - maddr <- parseAddress (strip_brackets h) - return (fmap PeerKey maddr) - -guardPortStrippedAddress :: Text -> SockAddr -> IO (Maybe ()) -guardPortStrippedAddress h laddr = do - maddr <- fmap (fmap (`withPort` 0)) $ parseAddress (strip_brackets h) - let laddr' = laddr `withPort` 0 - return $ maddr >>= guard . (==laddr') - - --- | Accepts a textual representation of a domainname --- JID suitable for client connections, and returns the --- coresponding ipv6 address JID suitable for peers paired --- with a SockAddr with the address part of that JID in --- binary form. If no suitable address could be resolved --- for the given name, Nothing is returned. -rewriteJIDForPeer :: Text -> IO (Maybe (Text,SockAddr)) -rewriteJIDForPeer jid = do - let (n,h,r) = splitJID jid - maddr <- fmap listToMaybe $ resolvePeer h - return $ flip fmap maddr $ \addr -> - let h' = addrToText addr - to' = unsplitJID (n,h',r) - in (to',addr) - -deliverToConsole :: PresenceState -> IO () -> Stanza -> IO () -deliverToConsole state fail msg = do - putStrLn $ "TODO: deliver to console" - did1 <- writeActiveTTY (consoleWriter state) msg - did2 <- writeAllPty (consoleWriter state) msg - if not (did1 || did2) then fail else return () - --- | deliver or error stanza -deliverMessage :: PresenceState - -> IO () - -> StanzaWrap (LockedChan Event) - -> IO () -deliverMessage state fail msg = - case stanzaOrigin msg of - NetworkOrigin senderk@(ClientKey {}) _ -> do - -- Case 1. Client -> Peer - mto <- do - flip (maybe $ return Nothing) (stanzaTo msg) $ \to -> do - rewriteJIDForPeer to - flip (maybe fail {- reverse lookup failure -}) - mto - $ \(to',addr) -> do - let k = PeerKey addr - chans <- atomically $ readTVar (keyToChan state) - flip (maybe fail) (Map.lookup k chans) $ \(Conn { connChan=chan - , auxAddr=laddr }) -> do - (n,r) <- forClient state senderk (return (Nothing,Nothing)) - $ \c -> return (Just (clientUser c), Just (clientResource c)) - -- original 'from' address is discarded. - let from' = unsplitJID (n,addrToText laddr,r) - -- dup <- atomically $ cloneStanza (msg { stanzaTo=Just to', stanzaFrom=Just from' }) - let dup = (msg { stanzaTo=Just to', stanzaFrom=Just from' }) - sendModifiedStanzaToPeer dup chan - NetworkOrigin senderk@(PeerKey {}) _ -> do - key_to_chan <- atomically $ readTVar (keyToChan state) - flip (maybe fail) (Map.lookup senderk key_to_chan) - $ \(Conn { connChan=sender_chan - , auxAddr=laddr }) -> do - flip (maybe fail) (stanzaTo msg) $ \to -> do - (mine,(n,h,r)) <- rewriteJIDForClient laddr to [] - if not mine then fail else do - let to' = unsplitJID (n,h,r) - cmap <- atomically . readTVar $ clientsByUser state - (from',chans,ks) <- do - flip (maybe $ return (Nothing,[],[])) n $ \n -> do - buds <- configText ConfigFiles.getBuddies n - from' <- do - flip (maybe $ return Nothing) (stanzaFrom msg) $ \from -> do - (_,trip) <- rewriteJIDForClient laddr from buds - return . Just $ unsplitJID trip - let nope = return (from',[],[]) - flip (maybe nope) (Map.lookup n cmap) $ \presence_container -> do - let ks = Map.keys (networkClients presence_container) - chans = mapMaybe (flip Map.lookup key_to_chan) ks - return (from',chans,ks) - putStrLn $ "chan count: " ++ show (length chans) - let msg' = msg { stanzaTo=Just to' - , stanzaFrom=from' } - if null chans then deliverToConsole state fail msg' else do - forM_ chans $ \Conn { connChan=chan} -> do - putStrLn $ "sending "++show (stanzaId msg)++" to clients "++show ks - -- TODO: Cloning isn't really neccessary unless there are multiple - -- destinations and we should probably transition to minimal cloning, - -- or else we should distinguish between announcable stanzas and - -- consumable stanzas and announcables use write-only broadcast - -- channels that must be cloned in order to be consumed. - -- For now, we are doing redundant cloning. - dup <- cloneStanza msg' - sendModifiedStanzaToClient dup - chan - - -setClientFlag :: PresenceState -> ConnectionKey -> Int8 -> IO () -setClientFlag state k flag = - atomically $ do - cmap <- readTVar (clients state) - flip (maybe $ return ()) (Map.lookup k cmap) $ \client -> do - setClientFlag0 client flag - -setClientFlag0 :: ClientState -> Int8 -> STM () -setClientFlag0 client flag = - modifyTVar' (clientFlags client) (\flgs -> flgs .|. flag) - -informSentRoster :: PresenceState -> ConnectionKey -> IO () -informSentRoster state k = do - setClientFlag state k cf_interested - - -subscribedPeers :: Text -> IO [SockAddr] -subscribedPeers user = do - jids <- configText ConfigFiles.getSubscribers user - let hosts = map ((\(_,h,_)->h) . splitJID) jids - fmap Map.keys $ resolveAllPeers hosts - --- | this JID is suitable for peers, not clients. -clientJID :: Conn -> ClientState -> Text -clientJID con client = unsplitJID ( Just $ clientUser client - , addrToText $ auxAddr con - , Just $ clientResource client) - --- | Send presence notification to subscribed peers. --- Note that a full JID from address will be added to the --- stanza if it is not present. -informClientPresence :: PresenceState - -> ConnectionKey -> StanzaWrap (LockedChan Event) -> IO () -informClientPresence state k stanza = do - forClient state k (return ()) $ \client -> do - informClientPresence0 state (Just k) client stanza - -informClientPresence0 :: PresenceState - -> Maybe ConnectionKey - -> ClientState - -> StanzaWrap (LockedChan Event) - -> IO () -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 - 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 - forM_ connected $ \con -> do - let from' = clientJID con client - mto <- runTraversableT $ do - to <- liftT $ stanzaTo stanza - (to',_) <- liftMT $ rewriteJIDForPeer to - return to' - dup <- cloneStanza stanza - sendModifiedStanzaToPeer dup { stanzaFrom = Just from' - , stanzaTo = mto } - (connChan con) - -informPeerPresence :: PresenceState - -> ConnectionKey - -> StanzaWrap (LockedChan Event) - -> IO () -informPeerPresence state k stanza = do - -- Presence must indicate full JID with resource... - putStrLn $ "xmppInformPeerPresence checking from address..." - flip (maybe $ return ()) (stanzaFrom stanza) $ \from -> do - let (muser,h,mresource) = splitJID from - putStrLn $ "xmppInformPeerPresence from = " ++ show from - -- flip (maybe $ return ()) mresource $ \resource -> do - flip (maybe $ return ()) muser $ \user -> do - - clients <- atomically $ do - - -- Update remotesByPeer... - rbp <- readTVar (remotesByPeer state) - let umap = maybe Map.empty id $ Map.lookup k rbp - rp = case (presenceShow $ stanzaType stanza) of - Offline -> - maybe Map.empty - (\resource -> - maybe (Map.empty) - (Map.delete resource . resources) - $ Map.lookup user umap) - mresource - - _ ->maybe Map.empty - (\resource -> - maybe (Map.singleton resource stanza) - (Map.insert resource stanza . resources ) - $ Map.lookup user umap) - mresource - umap' = Map.insert user (RemotePresence rp) umap - - flip (maybe $ return []) (case presenceShow $ stanzaType stanza of - Offline -> Just () - _ -> mresource >> Just ()) - $ \_ -> do - writeTVar (remotesByPeer state) $ Map.insert k umap' rbp - -- TODO: Store or delete the stanza (remotesByPeer) - - -- all clients, we'll filter available/authorized later - - ktc <- readTVar (keyToChan state) - runTraversableT $ do - (ck,client) <- liftMT $ fmap Map.toList $ readTVar (clients state) - con <- liftMaybe $ Map.lookup ck ktc - return (ck,con,client) - putStrLn $ "xmppInformPeerPresence (length clients="++show (length clients)++")" - 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 - putStrLn $ "reversing for client: " ++ show from - froms <- do -- flip (maybe $ return [from]) k . const $ do - let ClientKey laddr = ck - (_,trip) <- multiplyJIDForClient laddr from - return (map unsplitJID trip) - - putStrLn $ "sending to client: " ++ show (stanzaType stanza,froms) - forM_ froms $ \from' -> do - dup <- cloneStanza stanza - sendModifiedStanzaToClient (dup { stanzaFrom=Just from' }) - (connChan con) - -answerProbe :: PresenceState - -> Maybe Text -> ConnectionKey -> TChan Stanza -> IO () -answerProbe state mto k chan = do - -- putStrLn $ "answerProbe! " ++ show (stanzaType stanza) - ktc <- atomically $ readTVar (keyToChan state) - muser <- runTraversableT $ do - 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. - liftMT $ guardPortStrippedAddress h (auxAddr conn) - u <- liftT mu - let ch = addrToText (auxAddr conn) - return (u,conn,ch) - - flip (maybe $ return ()) muser $ \(u,conn,ch) -> do - - resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u - let gaddrs = groupBy (\a b -> snd a == snd b) (sort resolved_subs) - whitelist = do - xs <- gaddrs - x <- take 1 xs - guard $ snd x==k - mapMaybe fst xs - - -- -- only subscribed peers should get probe replies - -- addrs <- subscribedPeers u - - -- TODO: notify remote peer that they are unsubscribed? - -- reply <- makeInformSubscription "jabber:server" to from False - when (not $ null whitelist) $ do - - replies <- runTraversableT $ do - cbu <- lift . atomically $ readTVar (clientsByUser state) - let lpres = maybeToList $ Map.lookup u cbu - cw <- lift . atomically $ readTVar (cwClients $ consoleWriter state) - clientState <- liftT $ (lpres >>= Map.elems . networkClients) - ++ Map.elems cw - stanza <- liftIOMaybe $ atomically (readTVar (clientStatus clientState)) - stanza <- lift $ cloneStanza stanza - let jid = unsplitJID (Just $ clientUser clientState - , ch - ,Just $ clientResource clientState) - return stanza { stanzaFrom = Just jid - , stanzaType = (stanzaType stanza) - { presenceWhiteList = whitelist } - } - - forM_ replies $ \reply -> do - sendModifiedStanzaToPeer reply chan - - -- if no presence, send offline message - when (null replies) $ do - let jid = unsplitJID (Just u,ch,Nothing) - pstanza <- makePresenceStanza "jabber:server" (Just jid) Offline - atomically $ writeTChan (connChan conn) pstanza - -sendCachedPresence :: PresenceState -> ConnectionKey -> IO () -sendCachedPresence state k = do - forClient state k (return ()) $ \client -> do - rbp <- atomically $ readTVar (remotesByPeer state) - jids <- configText ConfigFiles.getBuddies (clientUser client) - let hosts = map ((\(_,h,_)->h) . splitJID) jids - addrs <- resolveAllPeers hosts - 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 - forM_ (Map.toList onlines) $ \(pk, umap) -> do - forM_ (Map.toList umap) $ \(user,rp) -> do - 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 - forM_ js $ \jid -> do - let from' = unsplitJID jid - dup <- cloneStanza stanza - sendModifiedStanzaToClient (dup { stanzaFrom=Just from' }) - (connChan con) - - pending <- configText ConfigFiles.getPending (clientUser client) - hostname <- textHostName - forM_ pending $ \pending_jid -> do - let cjid = unsplitJID ( Just $ clientUser client - , hostname - , Nothing ) - ask <- presenceSolicitation pending_jid cjid - sendModifiedStanzaToClient ask (connChan con) - - -- Note: relying on self peer connection to send - -- send local buddies. - return () - -addToRosterFile :: (MonadPlus t, Traversable t) => - (L.ByteString -> (L.ByteString -> IO (t L.ByteString)) - -> Maybe L.ByteString - -> t1) - -> Text -> Text -> [SockAddr] -> t1 -addToRosterFile doit whose to addrs = - modifyRosterFile doit whose to addrs True - -removeFromRosterFile :: (MonadPlus t, Traversable t) => - (L.ByteString -> (L.ByteString -> IO (t L.ByteString)) - -> Maybe L.ByteString - -> t1) - -> Text -> Text -> [SockAddr] -> t1 -removeFromRosterFile doit whose to addrs = - modifyRosterFile doit whose to addrs False - -modifyRosterFile :: (Traversable t, MonadPlus t) => - (L.ByteString -> (L.ByteString -> IO (t L.ByteString)) - -> Maybe L.ByteString - -> t1) - -> Text -> Text -> [SockAddr] -> Bool -> t1 -modifyRosterFile doit whose to addrs bAdd = do - let (mu,_,_) = splitJID to - cmp jid = runTraversableT $ do - let (msu,stored_h,mr) = splitJID (lazyByteStringToText jid) - -- Delete from file if a resource is present in file - (\f -> maybe f (const mzero) mr) $ do - -- Delete from file if no user is present in file - flip (maybe mzero) msu $ \stored_u -> do - -- do not delete anything if no user was specified - flip (maybe $ return jid) mu $ \u -> do - -- do not delete if stored user is same as specified - if stored_u /= u then return jid else do - stored_addrs <- lift $ resolvePeer stored_h - -- do not delete if failed to resolve - if null stored_addrs then return jid else do - -- delete if specified address matches stored - if null (stored_addrs \\ addrs) then mzero else do - -- keep - return jid - doit (textToLazyByteString whose) - cmp - (guard bAdd >> Just (textToLazyByteString to)) - -clientSubscriptionRequest :: PresenceState -> IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO () -clientSubscriptionRequest state fail k stanza chan = do - forClient state k fail $ \client -> do - flip (maybe fail) (stanzaTo stanza) $ \to -> do - putStrLn $ "Forwarding solictation to peer" - let (mu,h,_) = splitJID to - to <- return $ unsplitJID (mu,h,Nothing) -- delete resource - flip (maybe fail) mu $ \u -> do - addrs <- resolvePeer h - 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) - (readTVar $ associatedPeers state) - - case stanzaType stanza of - PresenceRequestSubscription True -> do - hostname <- textHostName - let cjid = unsplitJID (Just $ clientUser client, hostname,Nothing) - chans <- clientCons state ktc (clientUser client) - forM_ chans $ \( Conn { connChan=chan }, client ) -> do - -- roster update ask="subscribe" - update <- makeRosterUpdate cjid to - [ ("ask","subscribe") - , if is_subscribed then ("subscription","from") - else ("subscription","none") - ] - sendModifiedStanzaToClient update chan - _ -> return () - - let dsts = Map.fromList $ map ((,()) . PeerKey) addrs - cdsts = ktc `Map.intersection` dsts - forM_ (Map.toList cdsts) $ \(pk,con) -> do - -- if already connected, send solicitation ... - -- let from = clientJID con client - let from = unsplitJID ( Just $ clientUser client - , addrToText $ auxAddr con - , Nothing ) - mb <- rewriteJIDForPeer to - flip (maybe $ return ()) mb $ \(to',addr) -> do - dup <- cloneStanza stanza - sendModifiedStanzaToPeer (dup { stanzaTo = Just to' - , stanzaFrom = Just from }) - (connChan con) - let addrm = Map.fromList (map (,()) addrs) - when (not . Map.null $ addrm Map.\\ ap) $ do - -- Add peer if we are not already associated ... - sv <- atomically $ takeTMVar $ server state - addPeer sv (head addrs) - atomically $ putTMVar (server state) sv - - -resolvedFromRoster - :: (L.ByteString -> IO [L.ByteString]) - -> UserName -> IO [(Maybe UserName, ConnectionKey)] -resolvedFromRoster doit u = do - subs <- configText doit u - runTraversableT $ do - (mu,h,_) <- liftT $ splitJID `fmap` subs - addr <- liftMT $ fmap nub $ resolvePeer h - return (mu,PeerKey addr) - -clientCons :: PresenceState - -> Map ConnectionKey t -> Text -> IO [(t, ClientState)] -clientCons state ktc u = do - mlp <- atomically $ do - cmap <- readTVar $ clientsByUser state - return $ Map.lookup u cmap - let ks = do lp <- maybeToList mlp - Map.toList (networkClients lp) - doit (k,client) = do - con <- Map.lookup k ktc - return (con,client) - return $ mapMaybe doit ks - -peerSubscriptionRequest :: PresenceState -> IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO () -peerSubscriptionRequest state fail k stanza chan = do - putStrLn $ "Handling pending subscription from remote" - flip (maybe fail) (stanzaFrom stanza) $ \from -> do - flip (maybe fail) (stanzaTo stanza) $ \to -> do - let (mto_u,h,_) = splitJID to - (mfrom_u,from_h,_) = splitJID from - to <- return $ unsplitJID (mto_u,h,Nothing) -- delete resource - from <- return $ unsplitJID (mfrom_u,from_h,Nothing) -- delete resource - ktc <- atomically . readTVar $ keyToChan state - flip (maybe fail) (Map.lookup k ktc) - $ \Conn { auxAddr=laddr } -> do - (mine,totup) <- rewriteJIDForClient laddr to [] - if not mine then fail else do - (_,fromtup) <- rewriteJIDForClient laddr from [] - flip (maybe fail) mto_u $ \u -> do - flip (maybe fail) mfrom_u $ \from_u -> do - resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u - let already_subscribed = elem (mfrom_u,k) resolved_subs - is_wanted = case stanzaType stanza of - PresenceRequestSubscription b -> b - _ -> False -- Shouldn't happen. - -- Section 8 says (for presence of type "subscribe", the server MUST - -- adhere to the rules defined under Section 3 and summarized under - -- see Appendix A. (pariticularly Appendex A.3.1) - if already_subscribed == is_wanted - then do - -- contact ∈ subscribers --> SHOULD NOT, already handled - -- already subscribed, reply and quit - -- (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. - - -- add from-address to to's pending - addrs <- resolvePeer from_h - - -- Catch exception in case the user does not exist - if null addrs then fail else do - - let from' = unsplitJID fromtup - - already_pending <- - if is_wanted then - addToRosterFile ConfigFiles.modifyPending u from' addrs - else do - removeFromRosterFile ConfigFiles.modifySubscribers u from' addrs - reply <- makeInformSubscription "jabber:server" to from is_wanted - sendModifiedStanzaToPeer reply chan - return False - - -- contact ∉ subscribers & contact ∈ pending --> SHOULD NOT - when (not already_pending) $ do - -- contact ∉ subscribers & contact ∉ pending --> MUST - - chans <- clientCons state ktc u - forM_ chans $ \( Conn { connChan=chan }, client ) -> do - -- send to clients - -- TODO: interested/available clients only? - dup <- cloneStanza stanza - sendModifiedStanzaToClient dup { stanzaFrom = Just $ from' - , stanzaTo = Just $ unsplitJID totup } - chan - - -clientInformSubscription :: PresenceState - -> IO () - -> ConnectionKey - -> StanzaWrap (LockedChan Event) - -> IO () -clientInformSubscription state fail k stanza = do - forClient state k fail $ \client -> do - flip (maybe fail) (stanzaTo stanza) $ \to -> do - putStrLn $ "clientInformSubscription" - let (mu,h,mr) = splitJID to - addrs <- resolvePeer h - -- remove from pending - buds <- resolvedFromRoster ConfigFiles.getBuddies (clientUser client) - 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 - PresenceInformSubscription True -> - ( ("subscription", if is_buddy then "both" - else "from" ) - , ConfigFiles.modifySubscribers - , ConfigFiles.modifyOthers ) - _ -> ( ("subscription", if is_buddy then "to" - else "none" ) - , ConfigFiles.modifyOthers - , ConfigFiles.modifySubscribers ) - 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 = Map.lookup (clientUser client) cbu - let cs = maybe [] (Map.toList . networkClients) mlp - ktc <- readTVar (keyToChan state) - return (cs,ktc) - forM_ clients $ \(ck, 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] - sendModifiedStanzaToClient update (connChan con) - - -- notify peer - let dsts = Map.fromList $ map ((,()) . PeerKey) addrs - cdsts = ktc `Map.intersection` dsts - forM_ (Map.toList cdsts) $ \(pk,con) -> do - let from = clientJID con client - to' = unsplitJID (mu, peerKeyToText pk, Nothing) - dup <- cloneStanza stanza - sendModifiedStanzaToPeer (dup { stanzaTo = Just $ to' - , stanzaFrom = Just from }) - (connChan con) - answerProbe state (Just from) pk (connChan con) - -peerInformSubscription :: PresenceState - -> IO () - -> ConnectionKey - -> StanzaWrap (LockedChan Event) - -> IO () -peerInformSubscription state fail k stanza = do - putStrLn $ "TODO: peerInformSubscription" - -- remove from solicited - flip (maybe fail) (stanzaFrom stanza) $ \from -> do - ktc <- atomically $ readTVar (keyToChan state) - flip (maybe fail) (Map.lookup k ktc) - $ \(Conn { connChan=sender_chan - , auxAddr=laddr }) -> do - (_,(from_u,from_h,_)) <- rewriteJIDForClient laddr from [] - let from'' = unsplitJID (from_u,from_h,Nothing) - muser = do - to <- stanzaTo stanza - let (mu,to_h,to_r) = splitJID to - mu - -- TODO muser = Nothing when wanted=False - -- should probably mean unsubscribed for all users. - -- This would allow us to answer anonymous probes with 'unsubscribed'. - flip (maybe fail) muser $ \user -> 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 `intersect` subs - let (relationship,addf,remf) = - case stanzaType stanza of - PresenceInformSubscription True -> - ( ("subscription", if is_sub then "both" - else "to" ) - , ConfigFiles.modifyBuddies - , ConfigFiles.modifyOthers ) - _ -> ( ("subscription", if is_sub then "from" - else "none") - , ConfigFiles.modifyOthers - , ConfigFiles.modifyBuddies ) - addToRosterFile addf user from'' addrs - removeFromRosterFile remf user from'' addrs - - hostname <- textHostName - let to' = unsplitJID (Just user, hostname, Nothing) - chans <- clientCons state ktc user - forM_ chans $ \(Conn { connChan=chan }, 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 $ from'' - , stanzaTo = Just to' } - chan +import Presence main :: IO () main = runResourceT $ do @@ -1047,48 +52,9 @@ main = runResourceT $ do let verbosity = getSum $ flip foldMap args $ \case ('-':xs) -> Sum $ length (filter (=='-') xs) _ -> mempty - cw <- liftIO newConsoleWriter - state <- liftIO . atomically $ do - clients <- newTVar Map.empty - clientsByUser <- newTVar Map.empty - remotesByPeer <- newTVar Map.empty - associatedPeers <- newTVar Map.empty - xmpp <- newEmptyTMVar - keyToChan <- newTVar Map.empty - return PresenceState - { clients = clients - , clientsByUser = clientsByUser - , remotesByPeer = remotesByPeer - , associatedPeers = associatedPeers - , keyToChan = keyToChan - , server = xmpp - , consoleWriter = cw - } - sv <- xmppServer - XMPPServerParameters - { xmppChooseResourceName = chooseResourceName state - , xmppTellClientHisName = tellClientHisName state - , xmppTellMyNameToClient = textHostName - , xmppTellMyNameToPeer = \addr -> return $ addrToText addr - , xmppTellPeerHisName = return . peerKeyToText - , xmppTellClientNameOfPeer = flip peerKeyToResolvedName - , xmppNewConnection = newConn state - , xmppEOF = eofConn state - , xmppRosterBuddies = rosterGetBuddies state - , xmppRosterSubscribers = rosterGetSubscribers state - , xmppRosterSolicited = rosterGetSolicited state - , xmppRosterOthers = rosterGetOthers state - , xmppSubscribeToRoster = informSentRoster state - , xmppDeliverMessage = deliverMessage state - , xmppInformClientPresence = informClientPresence state - , xmppInformPeerPresence = informPeerPresence state - , xmppAnswerProbe = \k stanza chan -> answerProbe state (stanzaTo stanza) k chan - , xmppClientSubscriptionRequest = clientSubscriptionRequest state - , xmppPeerSubscriptionRequest = peerSubscriptionRequest state - , xmppClientInformSubscription = clientInformSubscription state - , xmppPeerInformSubscription = peerInformSubscription state - , xmppVerbosity = return verbosity - } + cw <- liftIO newConsoleWriter + state <- liftIO $ newPresenceState cw + sv <- xmppServer (presenceHooks state verbosity) liftIO $ do atomically $ putTMVar (server state) sv -- cgit v1.2.3