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. --- Presence/Presence.hs | 1045 ++++++++++++++++++++++++++++++++++++++++++++++++++ Presence/Util.hs | 59 +++ g | 11 +- xmppServer.hs | 1042 +------------------------------------------------ 4 files changed, 1117 insertions(+), 1040 deletions(-) create mode 100644 Presence/Presence.hs create mode 100644 Presence/Util.hs diff --git a/Presence/Presence.hs b/Presence/Presence.hs new file mode 100644 index 00000000..2344fb75 --- /dev/null +++ b/Presence/Presence.hs @@ -0,0 +1,1045 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} +module Presence where + +import System.Environment +import System.Posix.Signals +import Control.Concurrent (threadDelay,forkIO,forkOS,killThread,throwTo) +import Control.Concurrent.STM +import Control.Concurrent.STM.TMVar +import Control.Monad.Trans.Resource (runResourceT) +import Control.Monad.Trans +import Control.Monad.IO.Class (MonadIO, liftIO) +import Network.Socket ( SockAddr(..) ) +import System.Endian (fromBE32) +import Data.List (nub, (\\), intersect, groupBy, sort, sortBy ) +import Data.Ord (comparing ) +import Data.Monoid ( (<>), Sum(..), getSum ) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import qualified Data.Text.Encoding as Text +import Control.Monad +import Control.Monad.Fix +import qualified Network.BSD as BSD +import qualified Data.Text as Text +import Data.Text (Text) +import qualified Data.Map as Map +import Data.Map (Map) +import Control.Exception ({-evaluate,-}handle,SomeException(..),bracketOnError,ErrorCall(..)) +import System.IO.Error (isDoesNotExistError) +import System.Posix.User (getUserEntryForID,userName) +import qualified Data.ByteString.Lazy.Char8 as L +import qualified ConfigFiles +import Data.Maybe (maybeToList,listToMaybe,mapMaybe) +import Data.Bits +import Data.Int (Int8) +import Data.XML.Types (Event) +import System.Posix.Types (UserID,CPid) +import Control.Applicative + +import LockedChan (LockedChan) +import TraversableT +import UTmp (ProcessID,users) +import LocalPeerCred +import XMPPServer +import PeerResolve +import ConsoleWriter +import ClientState +import Util + +isPeerKey :: ConnectionKey -> Bool +isPeerKey k = case k of { PeerKey {} -> True ; _ -> False } + +isClientKey :: ConnectionKey -> Bool +isClientKey k = case k of { ClientKey {} -> True ; _ -> False } + +localJID :: Text -> Text -> IO Text +localJID user resource = do + hostname <- textHostName + return $ user <> "@" <> hostname <> "/" <> resource + +newPresenceState cw = 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 + } + + +presenceHooks state verbosity = 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 + } + + +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 + +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) +-} + +-- | 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)) + +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 diff --git a/Presence/Util.hs b/Presence/Util.hs new file mode 100644 index 00000000..8d9a9494 --- /dev/null +++ b/Presence/Util.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} +module Util where + +import qualified Data.ByteString.Lazy as L +import Data.Monoid +import qualified Data.Text as Text + ;import Data.Text (Text) +import qualified Data.Text.Encoding as Text +import qualified Network.BSD as BSD +import Network.Socket + +import Network.Address (setPort) + +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) + + +textHostName :: IO Text +textHostName = fmap Text.pack BSD.getHostName + +textToLazyByteString :: Text -> L.ByteString +textToLazyByteString s = L.fromChunks [Text.encodeUtf8 s] + +lazyByteStringToText :: L.ByteString -> Text +lazyByteStringToText = (foldr1 (<>) . map Text.decodeUtf8 . L.toChunks) + +-- | 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 + +sameAddress :: SockAddr -> SockAddr -> Bool +sameAddress laddr addr = setPort 0 laddr == setPort 0 addr + + diff --git a/g b/g index 736b2463..cab1b16e 100755 --- a/g +++ b/g @@ -1,5 +1,8 @@ #!/bin/bash -args="-fwarn-unused-imports -O2" +warn="-freverse-errors -fwarn-unused-imports -Wmissing-signatures -fdefer-typed-holes" +exts="-XOverloadedStrings -XRecordWildCards" +defs="-DBENCODE_AESON -DTHREAD_DEBUG" +hide="-hide-package crypto-random -hide-package crypto-api -hide-package crypto-numbers -hide-package cryptohash -hide-package prettyclass" root=${0%/*} cd "$root" @@ -7,9 +10,13 @@ cd "$root" me=${0##*/} me=${me%.*} ghc \ + $hide \ + $exts \ + $defs \ -hidir build/$me -odir build/$me \ -iPresence \ -iArchive \ + -isrc \ build/b/Presence/monitortty.o \ - $args \ + $warn \ "$@" 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