{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} module Presence where import System.Directory import System.IO.Error #ifndef THREAD_DEBUG import Control.Concurrent #else import Control.Concurrent.Lifted.Instrument #endif import Control.Concurrent.STM import Control.Monad.Trans import Network.Socket ( SockAddr(..) ) import Data.Char import Data.List (nub, (\\), intersect, groupBy, sort, sortBy ) import Data.Ord (comparing ) import Data.Monoid ((<>)) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Control.Monad import Data.Text (Text) import qualified Data.Map as Map import Data.Map (Map) import Control.Exception ({-evaluate,-}handle,SomeException(..)) import System.Posix.User (getUserEntryForID,userName) import qualified Data.ByteString.Lazy.Char8 as L import qualified ConfigFiles import Data.Maybe import Data.Bits import Data.Int (Int8) import Data.XML.Types (Event) import System.Posix.Types (UserID,CPid) import Control.Applicative import Crypto.PubKey.Curve25519 (SecretKey,toPublic) import ControlMaybe import DNSCache (parseAddress, strip_brackets, withPort) import LockedChan (LockedChan) import Text.Read (readMaybe) import UTmp (ProcessID,users) import LocalPeerCred import XMPPServer import ConsoleWriter import ClientState import Util import qualified Connection ;import Connection (PeerAddress (..), resolvePeer, reverseAddress) import Network.Tox.NodeId (key2id,parseNoSpamId,nospam64,NoSpamId(..),ToxProgress,ToxContact(..)) import Crypto.Tox (decodeSecret) import DPut import DebugTag {- isPeerKey :: ClientAddress -> Bool isPeerKey k = case k of { PeerKey {} -> True ; _ -> False } isClientKey :: ClientAddress -> Bool isClientKey k = case k of { ClientKey {} -> True ; _ -> False } -} localJID :: Text -> Text -> Text -> IO Text localJID user "." resource = do hostname <- textHostName return $ user <> "@" <> hostname <> "/" <> resource localJID user profile resource = return $ user <> "@" <> profile <> "/" <> resource -- | These hooks will be invoked in order to connect to *.tox hosts in the -- user's roster. -- -- The parameter k is a lookup key corresponding to an XMPP client. Each -- unique value should be able to hold a reference to the ToxID identity which -- should stay online until all interested keys have run 'deactivateAccount'. data ToxManager k = ToxManager -- | Put the given ToxID online. { activateAccount :: k -> Text -> SecretKey -> IO () -- | Take the given ToxID offline (assuming no other /k/ has a claim). , deactivateAccount :: k -> Text -> IO () , toxConnections :: Connection.Manager ToxProgress ToxContact -- | Given a remote Tox key, return the address of a connected peer. -- -- The arguments are our public key (in base64 format) followed by -- their public key (in base64 format). , resolveToxPeer :: Text -> Text -> IO (Maybe PeerAddress) } type ClientProfile = Text data PresenceState status = PresenceState { clients :: TVar (Map ClientAddress ClientState) , clientsByUser :: TVar (Map Text LocalPresence) , clientsByProfile :: TVar (Map Text LocalPresence) , remotesByPeer :: TVar (Map PeerAddress (Map UserName RemotePresence)) , server :: XMPPServer , manager :: ClientProfile -> Connection.Manager status Text , ckeyToChan :: TVar (Map ClientAddress Conn) , pkeyToChan :: TVar (Map PeerAddress Conn) , consoleWriter :: Maybe ConsoleWriter , toxManager :: Maybe (ToxManager ClientAddress) } newPresenceState :: Maybe ConsoleWriter -> Maybe (PresenceState status -> ToxManager ClientAddress) -> XMPPServer -> (ClientProfile -> Connection.Manager status Text) -> IO (PresenceState status) newPresenceState cw toxman sv man = atomically $ do clients <- newTVar Map.empty clientsByUser <- newTVar Map.empty clientsByProfile <- newTVar Map.empty remotesByPeer <- newTVar Map.empty ckeyToChan <- newTVar Map.empty pkeyToChan <- newTVar Map.empty let st = PresenceState { clients = clients , clientsByUser = clientsByUser , clientsByProfile = clientsByProfile , remotesByPeer = remotesByPeer , ckeyToChan = ckeyToChan , pkeyToChan = pkeyToChan , server = sv , manager = man , consoleWriter = cw , toxManager = Nothing } return $ st { toxManager = fmap ($ st) toxman } nameForClient :: PresenceState stat -> ClientAddress -> IO Text nameForClient state k = do mc <- atomically $ do cmap <- readTVar (clients state) return $ Map.lookup k cmap case mc of Nothing -> textHostName Just client -> case clientProfile client of "." -> textHostName profile -> return profile presenceHooks :: PresenceState stat -> Map Text MUC -> Int -> Maybe SockAddr -- ^ client-to-server bind address -> Maybe SockAddr -- ^ server-to-server bind address -> XMPPServerParameters presenceHooks state chats verbosity mclient mpeer = XMPPServerParameters { xmppChooseResourceName = chooseResourceName state , xmppTellClientHisName = tellClientHisName state , xmppTellMyNameToClient = nameForClient state , xmppTellMyNameToPeer = \(Local addr) -> return $ addrToText addr , xmppTellPeerHisName = return . peerKeyToText , 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 , xmppGroupChat = chats {- Map.singleton "chat" chat { mucRoomList = return [("testroom",Just "testroom")] , mucRoomOccupants = \case "testroom" -> return [("fakeperson",Nothing)] _ -> return [] , mucReservedNick = \case "testroom" -> return $ Just (return . Just) _ -> return Nothing , mucJoinRoom = \room nick caddr stanza -> do who <- tellClientHisName state caddr dput XJabber $ Text.unpack who ++ " joined " ++ Text.unpack room ++ " with nick: " ++ Text.unpack nick -- TODO: broadcast presence to all participants. -- See 7.2.3 of XEP-0045 -} , xmppClientBind = mclient , xmppPeerBind = mpeer } data LocalPresence = LocalPresence { networkClients :: Map ClientAddress ClientState -- TODO: loginClients } data RemotePresence = RemotePresence { resources :: Map ResourceName Stanza -- , localSubscribers :: Map Text () -- ^ subset of clientsByUser who should be -- notified about this presence. } pcSingletonNetworkClient :: ClientAddress -> ClientState -> LocalPresence pcSingletonNetworkClient key client = LocalPresence { networkClients = Map.singleton key client } pcInsertNetworkClient :: ClientAddress -> ClientState -> LocalPresence -> LocalPresence pcInsertNetworkClient key client pc = pc { networkClients = Map.insert key client (networkClients pc) } pcRemoveNewtworkClient :: ClientAddress -> 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) getConsolePids :: PresenceState stat -> 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 stat -> ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO Text chooseResourceName state k (Remote addr) clientsNameForMe desired = do muid <- getLocalPeerCred' addr (mtty,pid) <- getTTYandPID muid user <- getJabberUserForId muid status <- atomically $ newTVar Nothing flgs <- atomically $ newTVar 0 profile <- fmap (fromMaybe ".") $ forM ((,) <$> clientsNameForMe <*> toxManager state) $ \(wanted_profile0,toxman) -> case Text.splitAt 43 wanted_profile0 of (pub,".tox") -> do cdir <- ConfigFiles.configPath (L.fromChunks [Text.encodeUtf8 user]) "." "" #if !MIN_VERSION_directory(1,2,5) let listDirectory path = filter (`notElem` [".",".."]) <$> getDirectoryContents path #endif cfs <- map Text.pack <$> listDirectory cdir `catchIOError` (\e -> return []) let profiles = filter (\f -> Text.toLower f == Text.toLower wanted_profile0) cfs -- dput XMisc $ "Toxmpp profile " ++ show (user,wanted_profile0,profiles,cfs) let wanted_profile = head $ profiles ++ [wanted_profile0] secs <- configText ConfigFiles.getSecrets user wanted_profile case secs of sec:_ | Just s <- decodeSecret (Text.encodeUtf8 sec) , map toLower (show $ key2id $ toPublic s) == map toLower (Text.unpack pub) -> do activateAccount toxman k wanted_profile s dput XMisc $ "loaded tox secret " ++ show sec return wanted_profile _ -> do -- XXX: We should probably fail to connect when an -- invalid Tox profile is used. For now, we'll -- fall back to the Unix account login. dput XMisc "failed to find tox secret" return "." ("*.tox","") -> do dput XMisc $ "TODO: Match single tox key profile or generate first." -- TODO: Match single tox key profile or generate first. _todo _ -> return "." let client = ClientState { clientResource = maybe "fallback" id mtty , clientUser = user , clientProfile = profile , 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) (clientProfile client) forM_ buds $ \bud -> do let (_,h,_) = splitJID bud forkIO $ void $ resolvePeer (manager state $ clientProfile client) h atomically $ do modifyTVar' (clients state) $ Map.insert k client let add mb = Just $ maybe (pcSingletonNetworkClient k client) (pcInsertNetworkClient k client) mb modifyTVar' (clientsByUser state) $ Map.alter add (clientUser client) modifyTVar' (clientsByProfile state) $ Map.alter add (clientProfile client) localJID (clientUser client) (clientProfile 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 -- Perform action with 'ClientState' associated with the given 'ClientAddress'. -- If there is no associated 'ClientState', then perform the supplied fallback -- action. forClient :: PresenceState stat -> ClientAddress -> 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 stat -> ClientAddress -> IO Text tellClientHisName state k = forClient state k fallback go where fallback = localJID "nobody" "." "fallback" go client = localJID (clientUser client) (clientProfile client) (clientResource client) toMapUnit :: Ord k => [k] -> Map k () toMapUnit xs = Map.fromList $ map (,()) xs resolveAllPeers :: Connection.Manager stat Text -> [Text] -> IO (Map PeerAddress ()) resolveAllPeers man hosts = fmap (toMapUnit . concat) $ Prelude.mapM (fmap (take 1) . resolvePeer man) hosts -- Read a roster file and start trying to connect to all relevent peers. rosterGetStuff :: (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString]) -> PresenceState stat -> ClientAddress -> IO [Text] rosterGetStuff what state k = forClient state k (return []) $ \client -> do jids0 <- configText what (clientUser client) (clientProfile client) let jids = map splitJID jids0 -- Using case to bring 'status' type variable to Connection.Manager into scope. case state of PresenceState { server = sv } -> do let conns = manager state $ clientProfile client -- Grok peers to associate with from the roster: let isTox = do (me , ".tox") <- Just $ Text.splitAt 43 (clientProfile client) return me noToxUsers (u,h,r) | Text.isSuffixOf ".tox" h = unsplitJID (Nothing,h,r) | otherwise = unsplitJID (u,h,r) forM_ jids $ \(_,host,_) -> do -- We need either conns :: Connection.Manager TCPStatus Text -- or toxman :: ToxManager ClientAddress -- It is decided by checking hostnames for .tox ending. let policySetter = fromMaybe (Connection.setPolicy conns host) $ do isTox toxman <- toxManager state (them, ".tox") <- Just $ Text.splitAt 43 host meid <- readMaybe $ Text.unpack $ Text.take 43 (clientProfile client) themid <- readMaybe $ Text.unpack them return $ Connection.setPolicy (toxConnections toxman) (ToxContact meid themid) policySetter Connection.TryingToConnect return $ fromMaybe jids0 $ do isTox Just $ map noToxUsers jids rosterGetBuddies :: PresenceState stat -> ClientAddress -> IO [Text] rosterGetBuddies state k = rosterGetStuff ConfigFiles.getBuddies state k rosterGetSolicited :: PresenceState stat -> ClientAddress -> IO [Text] rosterGetSolicited = rosterGetStuff ConfigFiles.getSolicited -- XXX: Should we be connecting to these peers? rosterGetOthers :: PresenceState stat -> ClientAddress -> IO [Text] rosterGetOthers = rosterGetStuff ConfigFiles.getOthers rosterGetSubscribers :: PresenceState stat -> ClientAddress -> IO [Text] rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers data Conn = Conn { connChan :: TChan Stanza , auxData :: ConnectionData } -- Read config file as Text content rather than UTF8 bytestrings. configText :: Functor f => (ConfigFiles.User -> ConfigFiles.Profile -> f [L.ByteString]) -> Text -- user -> Text -- profile -> f [Text] -- items configText what u p = fmap (map lazyByteStringToText) $ what (textToLazyByteString u) (Text.unpack p) getBuddies' :: Text -> Text -> IO [Text] getBuddies' = configText ConfigFiles.getBuddies getSolicited' :: Text -> Text -> IO [Text] getSolicited' = configText ConfigFiles.getSolicited -- | Obtain from roster all buddies and pending buddies (called solicited -- regardless of whether we've yet delivered a friend-request) matching the -- supplied side-effecting predicate. -- -- Returned tuple: -- -- * Bool - True if buddy (should send probe). -- False if solicited (should send friend-request). -- -- * Maybe Username - Username field of contact. -- -- * Text - Unix user who owns this roster entry. -- -- * Text - Hostname as it appears in roster. -- getBuddiesAndSolicited :: PresenceState stat -> Text -- ^ Config profile: "." or tox host. -> (Text -> IO Bool) -- ^ Return True if you want this hostname. -> IO [(Bool, Maybe UserName, Text, Text)] getBuddiesAndSolicited state profile pred -- XXX: The following O(n²) nub may be a little -- too onerous. = fmap nub $ do cbu <- atomically $ readTVar $ clientsByUser state fmap concat $ sequence $ do (user,LocalPresence cmap) <- Map.toList cbu (isbud, getter) <- [(True ,getBuddies' ) ,(False,getSolicited')] return $ do buds <- map splitJID <$> getter user profile fmap concat $ forM buds $ \(u,h,r) -> do interested <- pred h if interested then return [(isbud,u,user,h)] else return [] sendProbesAndSolicitations :: PresenceState stat -> PeerAddress -> Local SockAddr -> TChan Stanza -> IO () sendProbesAndSolicitations state k (Local laddr) chan = do prof <- atomically $ do pktc <- readTVar (pkeyToChan state) return $ maybe "." (cdProfile . auxData) $ Map.lookup k pktc -- get all buddies & solicited matching k for all users xs <- getBuddiesAndSolicited state prof $ \case h | ".tox" `Text.isSuffixOf` h -> return False -- Tox probes/solicitations are handled in ToxToXMPP module. h -> do addrs <- nub <$> resolvePeer (manager state $ prof) h return $ k `elem` addrs -- Roster item resolves to /k/ peer. forM_ xs $ \(isbud,u,user,h) -> do let make = if isbud then presenceProbe else presenceSolicitation toh = peerKeyToText k jid = unsplitJID (u,toh,Nothing) me = addrToText laddr -- xmppTellMyNameToPeer 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. dput XJabber $ "probing "++show k++" for: " ++ show (isbud,jid) atomically $ writeTChan chan stanza -- reverse xs `seq` return () newConn :: PresenceState stat -> SockAddr -> ConnectionData -> TChan Stanza -> IO () newConn state saddr cdta outchan = case classifyConnection saddr cdta of Left (pkey,laddr) -> do atomically $ modifyTVar' (pkeyToChan state) $ Map.insert pkey Conn { connChan = outchan , auxData = cdta } sendProbesAndSolicitations state pkey laddr outchan Right (ckey,_) -> do atomically $ modifyTVar' (ckeyToChan state) $ Map.insert ckey Conn { connChan = outchan , auxData = cdta } delclient :: (Alternative m, Monad m) => ClientAddress -> 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 stat -> SockAddr -> ConnectionData -> IO () eofConn state saddr cdta = do case classifyConnection saddr cdta of Left (k,_) -> do h <- case cdType cdta of -- TODO: This should be cached (perhaps by rewriteJIDForClient?) so that we -- guarantee that the OFFLINE message matches the ONLINE message. -- For now, we reverse-resolve the peer key. XMPP -> -- For XMPP peers, informPeerPresence expects a textual -- representation of the IP address to reverse-resolve. return $ peerKeyToText k Tox -> do -- For Tox peers, informPeerPresence expects the actual hostname -- so we will use the one that the peer told us at greeting time. m <- atomically $ swapTVar (cdRemoteName cdta) Nothing case m of Nothing -> do dput XJabber $ "BUG: Tox peer didn't inform us of its name." -- The following fallback behavior is probably wrong. return $ peerKeyToText k Just toxname -> return toxname -- ioToSource terminated. -- -- dhtd: Network.Socket.getAddrInfo -- (called with preferred socket type/protocol: AddrInfo -- { addrFlags = [AI_NUMERICHOST], addrFamily = AF_UNSPEC -- , addrSocketType = NoSocketType, addrProtocol = 0 -- , addrAddress = -- , addrCanonName = } -- , host name: Just "DdhbLjiwaV0GAiGKgesNPbvj2TbhrBHEWEEc5icfvQN.tox" -- , service name: Just "0") -- : does not exist (Name or service not known) jids <- atomically $ do rbp <- readTVar (remotesByPeer state) return $ do umap <- maybeToList $ Map.lookup k rbp (u,rp) <- Map.toList umap r <- Map.keys (resources rp) let excludeEmpty "" = Nothing excludeEmpty x = Just x return $ unsplitJID (excludeEmpty u, h, excludeEmpty r) -- EOF PEER PeerAddress [d768:82dd:3e86:a6ba:8fb3:6f9c:6327:75d8%4236342772]:0: -- ["@[d768:82dd:3e86:a6ba:8fb3:6f9c:6327:75d8%4236342772]/"] -- dput XJabber $ "EOF PEER "++show k++": "++show jids forM_ jids $ \jid -> do stanza <- makePresenceStanza "jabber:client" (Just jid) Offline informPeerPresence state k stanza Right (k,_) -> do forClient state k (return ()) $ \client -> do forM_ (toxManager state) $ \toxman -> do case Text.splitAt 43 (clientProfile client) of (pub,".tox") -> deactivateAccount toxman k (clientProfile client) _ -> return () stanza <- makePresenceStanza "jabber:server" Nothing Offline informClientPresence state k stanza atomically $ do modifyTVar' (clientsByUser state) $ Map.alter (delclient k) (clientUser client) modifyTVar' (clientsByProfile state) $ Map.alter (delclient k) (clientProfile client) atomically $ case classifyConnection saddr cdta of Left (pkey,_) -> modifyTVar' (pkeyToChan state) $ Map.delete pkey Right (ckey,_) -> modifyTVar' (ckeyToChan state) $ Map.delete ckey {- parseRemoteAddress :: Text -> IO (Maybe (Remote SockAddr)) parseRemoteAddress s = fmap Remote <$> parseAddress s -} -- This attempts to reverse resolve a peers address to give the human-friendly -- domain name as it appears in the roster. It prefers host names that occur -- in the given list of JIDs, but will fall back to any reverse-resolved name -- and if it was unable to reverse the address, it will yield an ip address. peerKeyToResolvedName :: Connection.Manager s Text -> [Text] -> PeerAddress -> IO Text peerKeyToResolvedName man buds pk = do ns <- reverseAddress man pk let hs = map (\jid -> let (_,h,_)=splitJID jid in h) buds ns' = sortBy (comparing $ not . flip elem hs) ns return $ fromMaybe (peerKeyToText pk) (listToMaybe ns') -- | 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 :: Connection.Manager s Text -> Local SockAddr -> Text -> [Text] -> IO (Bool,(Maybe Text,Text,Maybe Text)) rewriteJIDForClient man (Local laddr) jid buds = do let (n,h,r) = splitJID jid -- dput XJabber $ "rewriteJIDForClient parsing " ++ show h maddr <- parseAddress (strip_brackets h) fromMaybe (return (False,(n,ip6literal h,r))) $ maddr <&> \saddr -> do let mine = sameAddress laddr saddr h' <- if mine then textHostName else peerKeyToResolvedName man buds (addrToPeerKey $ Remote saddr) return (mine,(n,h',r)) -- Given a local address and an IP-address JID, we return True if the JID is -- local, False otherwise. Additionally, a list of equivalent hostname JIDS -- are returned. multiplyJIDForClient :: Connection.Manager s Text -> ClientAddress -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)]) multiplyJIDForClient man k jid = do let (n,h,r) = splitJID jid -- dput XJabber $ "multiplyJIDForClient parsing " ++ show h maddr <- parseAddress (strip_brackets h) fromMaybe (return (False,[(n,ip6literal h,r)])) $ maddr <&> \saddr -> do let Local laddr = addrFromClientKey k mine = sameAddress laddr saddr names <- if mine then fmap (:[]) textHostName else reverseAddress man (addrToPeerKey $ Remote saddr) return (mine,map (\h' -> (n,h',r)) names) guardPortStrippedAddress :: Text -> Local SockAddr -> IO (Maybe ()) guardPortStrippedAddress h (Local laddr) = do -- dput XJabber $ "guardPortStrippedAddress parsing " ++ show h 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 PeerAddress 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 :: Connection.Manager s Text -> Text -> IO (Maybe (Text,PeerAddress)) rewriteJIDForPeer man jid = do let (n,h,r) = splitJID jid maddr <- fmap listToMaybe $ resolvePeer man h return $ flip fmap maddr $ \addr -> let h' = peerKeyToText addr to' = unsplitJID (n,h',r) in (to',addr) deliverToConsole :: PresenceState stat -> IO () -> Stanza -> IO () deliverToConsole PresenceState{ consoleWriter = Just cw } fail msg = do did1 <- writeActiveTTY cw msg did2 <- writeAllPty cw msg if not (did1 || did2) then fail else return () deliverToConsole _ fail _ = fail -- | deliver or error stanza deliverMessage :: PresenceState stat -> IO () -> StanzaWrap (LockedChan Event) -> IO () deliverMessage state fail msg = case stanzaOrigin msg of ClientOrigin senderk _ -> do -- Case 1. Client -> Peer mto <- join $ atomically $ do mclient <- Map.lookup senderk <$> readTVar (clients state) return $ do dput XJabber $ "deliverMessage: to="++show (stanzaTo msg,fmap clientProfile mclient) fromMaybe -- Resolve XMPP peer. (fmap join $ mapM (uncurry $ rewriteJIDForPeer . manager state) $ (,) <$> (clientProfile <$> mclient) <*> stanzaTo msg) $ do client <- mclient to <- stanzaTo msg let (mu,th,rsc) = splitJID to (toxman,me,_) <- weAreTox state client th return $ do dput XJabber $ "deliverMessage: weAreTox="++show me -- In case the client sends us a lower-cased version of the base64 -- tox key hostname, we resolve it by comparing it with roster entries. xs <- getBuddiesAndSolicited state (clientProfile client) $ \case rh | (_,".tox") <- Text.splitAt 43 rh , Text.toLower rh == Text.toLower th -> return True _ -> return False fmap join $ forM (listToMaybe xs) $ \(_,rmu,_,h) -> do let (them,_) = Text.splitAt 43 h maddr <- resolveToxPeer toxman me them let to' = unsplitJID (mu,h,rsc) return $ fmap (to',) maddr fromMaybe (do dput XJabber $ "Unable to resolve "++show (stanzaTo msg) fail {- reverse lookup failure -}) $ mto <&> \(to',k) -> do chans <- atomically $ readTVar (pkeyToChan state) fromMaybe (do dput XJabber $ "Peer unavailable: "++ show k fail) $ (Map.lookup k chans) <&> \conn -> do -- original 'from' address is discarded. from' <- forClient state senderk (return Nothing) $ return . Just . clientJID conn -- dup <- atomically $ cloneStanza (msg { stanzaTo=Just to', stanzaFrom=Just from' }) let dup = (msg { stanzaTo=Just to', stanzaFrom=from' }) sendModifiedStanzaToPeer dup (connChan conn) PeerOrigin senderk _ -> do (pchans,cchans) <- atomically $ do pc <- readTVar (pkeyToChan state) cc <- readTVar (ckeyToChan state) return (pc,cc) fromMaybe (do dput XJabber $ "Unknown peer " ++ show senderk fail) $ Map.lookup senderk pchans <&> \(Conn { connChan = sender_chan , auxData = ConnectionData (Left laddr) ctyp cprof _ }) -> do fromMaybe (do dput XJabber $ "Message missing \"to\" attribute." fail) $ (stanzaTo msg) <&> \to -> do (mine,(n,h,r)) <- case (ctyp,cprof) of (Tox,prof) -> let (n,h,r) = splitJID to in return ( h==prof, (n,h,r) ) _ -> rewriteJIDForClient (manager state cprof) laddr to [] if not mine then do dput XJabber $ "Address mis-match " ++ show (laddr,to) fail else do let to' = unsplitJID (n,h,r) let (cmapVar,ckey) = case ctyp of Tox -> (clientsByProfile state , Just cprof ) XMPP -> (clientsByUser state , n ) cmap <- atomically . readTVar $ cmapVar chans <- fmap (fromMaybe []) $ do forM (ckey >>= flip Map.lookup cmap) $ \presence_container -> do let ks = Map.keys (networkClients presence_container) chans = do (k,client) <- Map.toList $ networkClients presence_container chan <- maybeToList $ Map.lookup k cchans return (clientProfile client, clientUser client, chan) forM chans $ \(profile,user,chan) -> do buds <- configText ConfigFiles.getBuddies user profile from' <- case ctyp of Tox -> return $ stanzaFrom msg XMPP -> do forM (stanzaFrom msg) $ \from -> do (_,trip) <- rewriteJIDForClient (manager state cprof) laddr from buds return $ unsplitJID trip to' <- case ctyp of XMPP -> return $ stanzaTo msg Tox -> return $ Just $ unsplitJID (Just user, profile, Nothing) return (from',chan) dput XJabber $ "chan count: " ++ show (length chans) if null chans then when (ctyp == XMPP) $ do forM_ (stanzaFrom msg) $ \from -> do from' <- do -- Fallback to "." profile when no clients. buds <- maybe (return []) (\n -> configText ConfigFiles.getBuddies n ".") n (_,trip) <- rewriteJIDForClient (manager state cprof) laddr from buds return . Just $ unsplitJID trip let msg' = msg { stanzaTo=Just to' , stanzaFrom=from' } deliverToConsole state fail msg' else do forM_ chans $ \(from',Conn { connChan=chan}) -> do -- 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. let msg' = msg { stanzaTo=Just to' , stanzaFrom=from' } dup <- cloneStanza msg' sendModifiedStanzaToClient dup chan setClientFlag :: PresenceState stat -> ClientAddress -> Int8 -> IO () setClientFlag state k flag = atomically $ do cmap <- readTVar (clients state) forM_ (Map.lookup k cmap) $ \client -> do setClientFlag0 client flag setClientFlag0 :: ClientState -> Int8 -> STM () setClientFlag0 client flag = modifyTVar' (clientFlags client) (\flgs -> flgs .|. flag) informSentRoster :: PresenceState stat -> ClientAddress -> IO () informSentRoster state k = do setClientFlag state k cf_interested subscribedPeers :: Connection.Manager s Text -> Text -> Text -> IO [PeerAddress] subscribedPeers man user profile = do jids <- configText ConfigFiles.getSubscribers user profile let hosts = map ((\(_,h,_)->h) . splitJID) jids fmap Map.keys $ resolveAllPeers man hosts -- | this JID is suitable for peers, not clients. clientJID :: Conn -> ClientState -> Text clientJID con client = unsplitJID ( Just $ clientUser client , either (\(Local a) -> addrToText a) -- my host name, for peers (error $ unlines [ "clientJID wrongly used for client connection!" , "TODO: my host name for clients? nameForClient? localJID?"]) $ cdAddr $ auxData 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 stat -> ClientAddress -> StanzaWrap (LockedChan Event) -> IO () informClientPresence state k stanza = do forClient state k (return ()) $ \client -> do informClientPresence0 state (Just k) client stanza informClientPresence0 :: PresenceState stat -> Maybe ClientAddress -> 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 (manager state $ clientProfile client) (clientUser client) (clientProfile client) dput XJabber $ "informClientPresence(subscribedPeers) "++show (clientProfile client,addrs) ktc <- atomically $ readTVar (pkeyToChan state) let connected = mapMaybe (flip Map.lookup ktc) addrs forM_ connected $ \con -> do let from' = clientJID con client mto <- maybe (return Nothing) (fmap (fmap fst) . rewriteJIDForPeer (manager state $ clientProfile client)) (stanzaTo stanza) dup <- cloneStanza stanza sendModifiedStanzaToPeer dup { stanzaFrom = Just from' , stanzaTo = mto } (connChan con) informPeerPresence :: PresenceState stat -> PeerAddress -> StanzaWrap (LockedChan Event) -> IO () informPeerPresence state k stanza = do -- Presence must indicate full JID with resource... dput XJabber $ "xmppInformPeerPresence checking from address..." forM_ (stanzaFrom stanza) $ \from -> do let (muser0,h,mresource0) = splitJID from -- We'll allow the case that user and resource are simultaneously -- absent. They will be stored in the remotesByPeer map using the -- empty string. This is to accommodate the tox protocol which didn't -- anticipate a single peer would have multiple users or front-ends. (muser,mresource) = case (muser0,mresource0) of (Nothing,Nothing) -> (Just "", Just "") _ -> (muser0,mresource0) dput XJabber $ "xmppInformPeerPresence from = " ++ show from -- forM_ mresource $ \resource -> do forM_ 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 fromMaybe (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 (ckeyToChan state) cmap <- readTVar (clients state) return $ do (ck,client) <- Map.toList cmap con <- maybeToList $ Map.lookup ck ktc return (ck,con,client) dput XJabber $ "xmppInformPeerPresence (length clients="++show (length clients)++")" (ctyp,cprof) <- atomically $ do mconn <- Map.lookup k <$> readTVar (pkeyToChan state) return $ fromMaybe (XMPP,".") $ do ConnectionData _ ctyp cprof _ <- auxData <$> mconn return (ctyp,cprof) forM_ clients $ \(ck,con,client) -> do -- (TODO: appropriately authorized clients only.) -- For now, all "available" clients (available = sent initial presence) is_avail <- atomically $ clientIsAvailable client when is_avail $ do -- reversing for client: ("DdhbLjiwaV0GAiGKgesNPbvj2TbhrBHEWEEc5icfvQN.tox" -- ,XMPP,"OrjBG.GyWuQhGc1pb0KssgmYAocohFh35Vx8mREC9Nu.tox",".") dput XJabber $ "reversing for client: " ++ show (from,ctyp,clientProfile client,cprof) froms <- case ctyp of Tox | clientProfile client == cprof -> return [from] _ -> do -- flip (maybe $ return [from]) k . const $ do (_,trip) <- multiplyJIDForClient (manager state $ clientProfile client) ck from return (map unsplitJID trip) dput XJabber $ "sending to client: " ++ show (stanzaType stanza,froms) forM_ froms $ \from' -> do dup <- cloneStanza stanza sendModifiedStanzaToClient (dup { stanzaFrom=Just from' }) (connChan con) consoleClients :: PresenceState stat -> STM (Map Text ClientState) consoleClients PresenceState{ consoleWriter = Just cw } = readTVar (cwClients cw) consoleClients _ = return Map.empty answerProbe :: PresenceState stat -> Maybe Text -> PeerAddress -> TChan Stanza -> IO () answerProbe state mto k chan = do -- dput XJabber $ "answerProbe! " ++ show (stanzaType stanza) ktc <- atomically $ readTVar (pkeyToChan state) muser <- fmap join $ sequence $ do to <- mto conn <- Map.lookup k ktc let (mu,h,_) = splitJID to -- TODO: currently resource-id is ignored on presence -- probes. Is this correct? Check the spec. Left laddr = cdAddr $ auxData conn ch = addrToText a where Local a = laddr u <- mu Just $ do guardPortStrippedAddress h laddr <&> maybe Nothing (\_ -> Just (u,conn,ch)) forM_ muser $ \(u,conn,ch) -> do profiles <- releventProfiles (cdType $ auxData conn) u forM_ profiles $ \profile -> do -- only subscribed peers should get probe replies let man = manager state $ cdProfile $ auxData conn resolved_subs <- resolvedFromRoster man ConfigFiles.getSubscribers u profile let gaddrs = groupBy sameHost (sort resolved_subs) sameHost a b = (snd a == snd b) -- (==) `on` snd whitelist = do xs <- gaddrs -- group of subscribed jids on the same host x <- take 1 xs -- the host from the group guard $ snd x==k -- only hosts matching the key /k/ mapMaybe fst xs -- all users subscribed at the remote peer /k/ -- TODO: notify remote peer that they are unsubscribed? -- reply <- makeInformSubscription "jabber:server" to from False when (not $ null whitelist) $ do replies <- catMaybes <$> do -- runTraversableT $ do cbu <- atomically $ readTVar (clientsByUser state) -- Map Text LocalPresence let lpres = maybeToList $ Map.lookup u cbu cw <- atomically $ consoleClients state -- Map Text ClientState forM ((lpres >>= Map.elems . networkClients) ++ Map.elems cw) $ \clientState -> do -- liftIOMaybe :: IO (Maybe a) -> TraversableT [] IO a mstanza <- atomically $ readTVar (clientStatus clientState) forM mstanza $ \stanza0 -> do stanza <- cloneStanza stanza0 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 -- Send friend requests and remote presences stored in remotesByPeer to XMPP -- clients. sendCachedPresence :: PresenceState stat -> ClientAddress -> IO () sendCachedPresence state k = do forClient state k (return ()) $ \client -> do rbp <- atomically $ readTVar (remotesByPeer state) jids <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client) let hosts = map ((\(_,h,_)->h) . splitJID) jids addrs <- resolveAllPeers (manager state $ clientProfile client) hosts let onlines = rbp `Map.intersection` addrs mcon <- atomically $ do ktc <- readTVar (ckeyToChan state) return $ Map.lookup k ktc forM_ mcon $ \con -> do 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 (manager state $ clientProfile client) k 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) (clientProfile client) hostname <- nameForClient state k 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 :: Connection.Manager s Text -> (ConfigFiles.User -> ConfigFiles.Profile -> (L.ByteString -> IO (Maybe L.ByteString)) -> Maybe L.ByteString -> t1) -> Text -- user -> Text -- profile -> Text -> [PeerAddress] -> t1 addToRosterFile man doit whose profile to addrs = modifyRosterFile man doit whose profile to addrs True False removeFromRosterFile :: Connection.Manager s Text -> (ConfigFiles.User -> ConfigFiles.Profile -> (L.ByteString -> IO (Maybe L.ByteString)) -> Maybe L.ByteString -> t1) -> Text -- user -> Text -- profile -> Text -> [PeerAddress] -> t1 removeFromRosterFile man doit whose profile to addrs = modifyRosterFile man doit whose profile to addrs False False -- | Sanity-checked roster file manipulation. Primarily, this function handles -- hostname aliases. modifyRosterFile :: Connection.Manager s Text -> (ConfigFiles.User -> ConfigFiles.Profile -> (L.ByteString -> IO (Maybe L.ByteString)) -> Maybe L.ByteString -> t1) -- ^ Lower-level modification function -- indicating which file is being modified. -- Valid choices from ConfigFiles module: -- -- * modifySolicited -- -- * modifyBuddies -- -- * modifyPending -- -- * modifySubscribers -> Text -- ^ user -> Text -- ^ profile -> Text -- ^ JID that will be added or removed a hostname -> [PeerAddress] -- ^ Alias addresses for hostname in the JID. -> Bool -- ^ True if adding, otherwise False -> Bool -- ^ True to allow deleting all users at a host. -> t1 modifyRosterFile man doit whose profile to addrs bAdd bWildCard = do let (mu,_,_) = splitJID to -- For each jid in the file, this function will decide whether to keep -- it (possibly modified) which is indicated by Just _ or to remove the -- item from the file which is indicated by Nothing. cmp :: L.ByteString -> IO (Maybe L.ByteString) cmp jid = do let (msu,stored_h,mr) = splitJID (lazyByteStringToText jid) keep = return (Just jid) :: IO (Maybe L.ByteString) delete = return Nothing :: IO (Maybe L.ByteString) iocheck = do stored_addrs <- resolvePeer man stored_h -- TODO: don't resolve .tox peers. case stored_addrs of [] -> keep -- do not delete if failed to resolve xs | null (xs \\ addrs) -> delete -- hostname alias, delete _ -> keep fmap join $ sequence $ do guard $ isNothing mr -- delete if resource specified in file. if mu == msu || bWildCard then Just iocheck -- do not delete unless hostname alias else Just keep -- do not delete if user field doesn't match. doit (textToLazyByteString whose) (Text.unpack profile) cmp (guard bAdd >> Just (textToLazyByteString to)) clientSubscriptionRequest :: PresenceState stat -> IO () -> ClientAddress -> Stanza -> TChan Stanza -> IO () clientSubscriptionRequest state fail k stanza chan = do forClient state k fail $ \client -> do fromMaybe fail $ (splitJID <$> stanzaTo stanza) <&> \(mu,h,_) -> do dput XJabber $ "Forwarding solicitation to peer" let to0 = unsplitJID (mu,h,Nothing) -- deleted resource cuser = clientUser client cprof = clientProfile client man = manager state cprof mto = if ".tox" `Text.isSuffixOf` cprof then case parseNoSpamId to0 of Right toxjid@(NoSpamId nspam _) -> Just ( Text.pack $ '$' : nospam64 nspam , Text.pack $ show toxjid , return [] ) Left _ | Text.isSuffixOf ".tox" h -> Nothing Left _ | Text.all isHexDigit h && Text.length h == 76 -> Nothing Left _ -> fmap (\u -> (u, to0 ,resolvePeer man h)) mu else fmap (\u -> (u, to0 ,resolvePeer man h)) mu fromMaybe fail $ mto <&> \(u,to,resolv) -> do -- add to-address to from's solicited dput XJabber $ unlines [ "to0=" ++ Text.unpack to0 , "to=" ++ show (Text.unpack to) ] addrs <- resolv addToRosterFile man ConfigFiles.modifySolicited cuser cprof to addrs removeFromRosterFile man ConfigFiles.modifyBuddies cuser cprof to addrs resolved_subs <- resolvedFromRoster man ConfigFiles.getSubscribers cuser cprof let is_subscribed = not . null $ [ (mu, a) | a <- addrs ] `intersect` resolved_subs -- subscribers: "from" -- buddies: "to" case state of PresenceState { server = svVar } -> do (cktc,pktc,(sv,conns)) <- atomically $ do cktc <- readTVar $ ckeyToChan state pktc <- readTVar $ pkeyToChan state return (cktc,pktc,(server state,man)) -- Update roster for each client. case stanzaType stanza of PresenceRequestSubscription True -> do hostname <- nameForClient state k let cjid = unsplitJID (Just $ clientUser client, hostname,Nothing) chans <- clientCons state cktc (clientUser client) forM_ chans $ \( Conn { connChan=chan }, client ) -> do -- roster update ask="subscribe" update <- myMakeRosterUpdate (clientProfile client) cjid to [ ("ask","subscribe") , if is_subscribed then ("subscription","from") else ("subscription","none") ] sendModifiedStanzaToClient update chan when (to /= to0) $ do removal <- myMakeRosterUpdate (clientProfile client) cjid to0 [ ("subscription","remove") ] sendModifiedStanzaToClient removal chan _ -> return () -- Send friend request to peer. let dsts = pktc `Map.intersection` toMapUnit addrs forM_ (Map.toList dsts) $ \(pk,con) -> do -- if already connected, send solicitation ... -- let from = clientJID con client let Left laddr = cdAddr $ auxData con from = unsplitJID ( Just $ clientUser client , (\(Local a) -> addrToText a) $ laddr , Nothing ) mb <- rewriteJIDForPeer (manager state $ cdProfile $ auxData con) to forM_ mb $ \(to',addr) -> do dup <- cloneStanza stanza sendModifiedStanzaToPeer (dup { stanzaTo = Just to' , stanzaFrom = Just from }) (connChan con) let policySetter = fromMaybe (Connection.setPolicy conns h) $ do (toxman,_,_) <- weAreTox state client h meid <- readMaybe $ Text.unpack $ Text.take 43 (clientProfile client) themid <- readMaybe $ Text.unpack h Just $ Connection.setPolicy (toxConnections toxman) (ToxContact meid themid) -- Add peer if we are not already associated ... policySetter Connection.TryingToConnect weAreTox :: PresenceState stat -> ClientState -> Text -> Maybe (ToxManager ClientAddress,Text{- me -},Text{- them -}) weAreTox state client h = do toxman <- toxManager state (me , ".tox") <- Just $ Text.splitAt 43 (clientProfile client) (them, ".tox") <- Just $ Text.splitAt 43 h return (toxman,me,them) resolvedFromRoster :: Connection.Manager s Text -> (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString]) -> UserName -> Text -> IO [(Maybe UserName, PeerAddress)] resolvedFromRoster man doit u profile = concat <$> do subs <- configText doit u profile forM (splitJID `fmap` subs) $ \(mu,h,_) -> do addrs <- fmap nub $ resolvePeer man h return $ map (mu,) addrs clientCons :: PresenceState stat -> Map ClientAddress t -> Text -> IO [(t, ClientState)] clientCons state ktc u = map snd <$> clientCons' state ktc u clientCons' :: PresenceState stat -> Map ClientAddress t -> Text -> IO [(ClientAddress,(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 (k,(con,client)) return $ mapMaybe doit ks releventProfiles :: ConnectionType -> Text -> IO [Text] releventProfiles XMPP _ = return ["."] releventProfiles ctyp user = do -- TODO: Return all the ".tox" profiles that a user has under his -- .presence/ directory. return [] peerSubscriptionRequest :: PresenceState stat -> IO () -> PeerAddress -> Stanza -> TChan Stanza -> IO () peerSubscriptionRequest state fail k stanza chan = do dput XJabber $ "Handling pending subscription from remote" fromMaybe fail $ (stanzaFrom stanza) <&> \from -> do fromMaybe 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 (pktc,cktc,cmap) <- atomically $ do cktc <- readTVar (ckeyToChan state) pktc <- readTVar (pkeyToChan state) cmap <- readTVar (clients state) return (pktc,cktc,cmap) fromMaybe fail $ (Map.lookup k pktc) <&> \Conn { auxData=ConnectionData (Left laddr) ctyp profile _ } -> do (mine,totup) <- case (ctyp,profile) of (Tox,p) -> let (u,h,r) = splitJID to in return ( h == p, (u,h,r) ) _ -> rewriteJIDForClient (manager state profile) laddr to [] if not mine then fail else do (_,fromtup) <- rewriteJIDForClient (manager state profile) laddr from [] fromMaybe fail $ mto_u <&> \u -> do fromMaybe fail $ mfrom_u <&> \from_u -> do resolved_subs <- resolvedFromRoster (manager state profile) ConfigFiles.getSubscribers u profile 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 (manager state profile) from_h -- Catch exception in case the user does not exist if null addrs then fail else do let from' = unsplitJID fromtup -- Update roster files (subscribe: add to pending, unsubscribe: remove from subscribers). already_pending <- if is_wanted then addToRosterFile (manager state profile) ConfigFiles.modifyPending u profile from' addrs else do removeFromRosterFile (manager state profile) ConfigFiles.modifySubscribers u profile 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 cktc 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 myMakeRosterUpdate prf tojid contact as | ".tox" `Text.isSuffixOf` prf , (Just u,h,r) <- splitJID contact , ".tox" `Text.isSuffixOf` u = XMPPServer.makeRosterUpdate tojid (unsplitJID (Nothing,h,r)) as myMakeRosterUpdate _ tojid contact as = XMPPServer.makeRosterUpdate tojid contact as clientInformSubscription :: PresenceState stat -> IO () -> ClientAddress -> StanzaWrap (LockedChan Event) -> IO () clientInformSubscription state fail k stanza = do forClient state k fail $ \client -> do fromMaybe fail $ (stanzaTo stanza) <&> \to -> do dput XJabber $ "clientInformSubscription" let (mu,h,mr) = splitJID to man = manager state $ clientProfile client addrs <- resolvePeer man h -- remove from pending buds <- resolvedFromRoster man ConfigFiles.getBuddies (clientUser client) (clientProfile client) let is_buddy = not . null $ map (mu,) addrs `intersect` buds removeFromRosterFile man ConfigFiles.modifyPending (clientUser client) (clientProfile 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 man addf (clientUser client) (clientProfile client) to addrs removeFromRosterFile man remf (clientUser client) (clientProfile client) to addrs do cbu <- atomically $ readTVar (clientsByUser state) dput XJabber $ "cbu = " ++ show (fmap (fmap clientPid . networkClients) cbu) -- send roster update to clients (clients,ktc,pktc) <- atomically $ do cbu <- readTVar (clientsByUser state) let mlp = Map.lookup (clientUser client) cbu let cs = maybe [] (Map.toList . networkClients) mlp ktc <- readTVar (ckeyToChan state) pktc <- readTVar (pkeyToChan state) return (cs,ktc,pktc) forM_ clients $ \(ck, client) -> do is_intereseted <- atomically $ clientIsInterested client dput XJabber $ "clientIsInterested: "++show is_intereseted is_intereseted <- atomically $ clientIsInterested client when is_intereseted $ do forM_ (Map.lookup ck ktc) $ \con -> do hostname <- nameForClient state ck -- TODO: Should cjid include the resource? let cjid = unsplitJID (mu, hostname, Nothing) update <- myMakeRosterUpdate (clientProfile client) cjid to [relationship] sendModifiedStanzaToClient update (connChan con) -- notify peer let dsts = toMapUnit addrs cdsts = pktc `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 stat -> IO () -> PeerAddress -> StanzaWrap (LockedChan Event) -> IO () peerInformSubscription state fail k stanza = do dput XJabber $ "TODO: peerInformSubscription" -- remove from solicited fromMaybe fail $ (stanzaFrom stanza) <&> \from -> do (ktc,cktc,cmap) <- atomically $ do pktc <- readTVar (pkeyToChan state) cktc <- readTVar (ckeyToChan state) cmap <- readTVar (clients state) return (pktc,cktc,cmap) fromMaybe fail $ Map.lookup k ktc <&> \(Conn { connChan=sender_chan , auxData =ConnectionData (Left laddr) ctyp profile _ }) -> do let man = manager state profile (from_u,from_h,_) <- case ctyp of Tox -> return $ splitJID from XMPP -> snd <$> rewriteJIDForClient man 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'. fromMaybe fail $ muser <&> \user -> do addrs <- resolvePeer man from_h was_solicited <- removeFromRosterFile man ConfigFiles.modifySolicited user profile from'' addrs subs <- resolvedFromRoster man ConfigFiles.getSubscribers user profile let is_sub = not . null $ map (from_u,) addrs `intersect` subs dput XJabber $ "DEBUG peerInformSubscription (is_sub,typ)=" ++ show (is_sub,stanzaType stanza) 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 man addf user profile from'' addrs removeFromRosterFile man remf user profile from'' addrs chans <- clientCons' state cktc user forM_ chans $ \(ckey,(Conn { connChan=chan }, client)) -> do hostname <- nameForClient state ckey let to' = unsplitJID (Just user, hostname, Nothing) update <- myMakeRosterUpdate (clientProfile client) 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