From 55db1198b3da0c706f2b9f1ed9c8fd11fc4ae552 Mon Sep 17 00:00:00 2001 From: joe Date: Sun, 24 Jun 2018 02:27:18 -0400 Subject: XMPP: Type-checking on various uses of SockAddr. --- Presence/Presence.hs | 389 +++++++++++++++++++++++++++------------------------ 1 file changed, 206 insertions(+), 183 deletions(-) (limited to 'Presence/Presence.hs') diff --git a/Presence/Presence.hs b/Presence/Presence.hs index af6597b6..244bbead 100644 --- a/Presence/Presence.hs +++ b/Presence/Presence.hs @@ -53,11 +53,13 @@ import Network.Tox.NodeId (key2id) import Crypto.Tox (decodeSecret) import DPut -isPeerKey :: ConnectionKey -> Bool +{- +isPeerKey :: ClientAddress -> Bool isPeerKey k = case k of { PeerKey {} -> True ; _ -> False } -isClientKey :: ConnectionKey -> Bool +isClientKey :: ClientAddress -> Bool isClientKey k = case k of { ClientKey {} -> True ; _ -> False } +-} localJID :: Text -> Text -> Text -> IO Text localJID user "." resource = do @@ -86,20 +88,21 @@ data ToxManager k = ToxManager } data PresenceState = forall status. PresenceState - { clients :: TVar (Map ConnectionKey ClientState) + { clients :: TVar (Map ClientAddress ClientState) , clientsByUser :: TVar (Map Text LocalPresence) , clientsByProfile :: TVar (Map Text LocalPresence) - , remotesByPeer :: TVar (Map ConnectionKey + , remotesByPeer :: TVar (Map PeerAddress (Map UserName RemotePresence)) , server :: TMVar (XMPPServer, Connection.Manager status Text) - , keyToChan :: TVar (Map ConnectionKey Conn) + , ckeyToChan :: TVar (Map ClientAddress Conn) + , pkeyToChan :: TVar (Map PeerAddress Conn) , consoleWriter :: Maybe ConsoleWriter - , toxManager :: Maybe (ToxManager ConnectionKey) + , toxManager :: Maybe (ToxManager ClientAddress) } newPresenceState :: Maybe ConsoleWriter - -> Maybe (PresenceState -> ToxManager ConnectionKey) + -> Maybe (PresenceState -> ToxManager ClientAddress) -> TMVar (XMPPServer, Connection.Manager status Text) -> IO PresenceState newPresenceState cw toxman xmpp = atomically $ do @@ -107,13 +110,15 @@ newPresenceState cw toxman xmpp = atomically $ do clientsByUser <- newTVar Map.empty clientsByProfile <- newTVar Map.empty remotesByPeer <- newTVar Map.empty - keyToChan <- newTVar Map.empty + ckeyToChan <- newTVar Map.empty + pkeyToChan <- newTVar Map.empty let st = PresenceState { clients = clients , clientsByUser = clientsByUser , clientsByProfile = clientsByProfile , remotesByPeer = remotesByPeer - , keyToChan = keyToChan + , ckeyToChan = ckeyToChan + , pkeyToChan = pkeyToChan , server = xmpp , consoleWriter = cw , toxManager = Nothing @@ -121,7 +126,7 @@ newPresenceState cw toxman xmpp = atomically $ do return $ st { toxManager = fmap ($ st) toxman } -nameForClient :: PresenceState -> ConnectionKey -> IO Text +nameForClient :: PresenceState -> ClientAddress -> IO Text nameForClient state k = do mc <- atomically $ do cmap <- readTVar (clients state) @@ -139,9 +144,8 @@ presenceHooks state verbosity mclient mpeer = XMPPServerParameters { xmppChooseResourceName = chooseResourceName state , xmppTellClientHisName = tellClientHisName state , xmppTellMyNameToClient = nameForClient state - , xmppTellMyNameToPeer = \addr -> return $ addrToText addr + , xmppTellMyNameToPeer = \(Local addr) -> return $ addrToText addr , xmppTellPeerHisName = return . peerKeyToText - , xmppTellClientNameOfPeer = flip peerKeyToResolvedName , xmppNewConnection = newConn state , xmppEOF = eofConn state , xmppRosterBuddies = rosterGetBuddies state @@ -164,7 +168,7 @@ presenceHooks state verbosity mclient mpeer = XMPPServerParameters data LocalPresence = LocalPresence - { networkClients :: Map ConnectionKey ClientState + { networkClients :: Map ClientAddress ClientState -- TODO: loginClients } @@ -177,18 +181,17 @@ data RemotePresence = RemotePresence -pcSingletonNetworkClient :: ConnectionKey - -> ClientState -> LocalPresence +pcSingletonNetworkClient :: ClientAddress -> ClientState -> LocalPresence pcSingletonNetworkClient key client = LocalPresence { networkClients = Map.singleton key client } -pcInsertNetworkClient :: ConnectionKey -> ClientState -> LocalPresence -> LocalPresence +pcInsertNetworkClient :: ClientAddress -> ClientState -> LocalPresence -> LocalPresence pcInsertNetworkClient key client pc = pc { networkClients = Map.insert key client (networkClients pc) } -pcRemoveNewtworkClient :: ConnectionKey +pcRemoveNewtworkClient :: ClientAddress -> LocalPresence -> Maybe LocalPresence pcRemoveNewtworkClient key pc = if pcIsEmpty pc' then Nothing else Just pc' @@ -215,8 +218,8 @@ identifyTTY' ttypids uid inode = ttypid textify (tty,pid) = (fmap lazyByteStringToText tty, pid) chooseResourceName :: PresenceState - -> ConnectionKey -> SockAddr -> Maybe Text -> Maybe Text -> IO Text -chooseResourceName state k addr clientsNameForMe desired = do + -> 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 @@ -297,17 +300,17 @@ chooseResourceName state k addr clientsNameForMe desired = do ) muid --- Perform action with 'ClientState' associated with the given 'ConnectionKey'. +-- Perform action with 'ClientState' associated with the given 'ClientAddress'. -- If there is no associated 'ClientState', then perform the supplied fallback -- action. -forClient :: PresenceState -> ConnectionKey -> IO b -> (ClientState -> IO b) -> IO b +forClient :: PresenceState -> 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 -> ConnectionKey -> IO Text +tellClientHisName :: PresenceState -> ClientAddress -> IO Text tellClientHisName state k = forClient state k fallback go where fallback = localJID "nobody" "." "fallback" @@ -316,14 +319,14 @@ tellClientHisName state k = forClient state k fallback go toMapUnit :: Ord k => [k] -> Map k () toMapUnit xs = Map.fromList $ map (,()) xs -resolveAllPeers :: [Text] -> IO (Map SockAddr ()) +resolveAllPeers :: [Text] -> IO (Map PeerAddress ()) resolveAllPeers hosts = fmap (toMapUnit . concat) $ Prelude.mapM (fmap (take 1) . resolvePeer) hosts -- Read a roster file and start trying to connect to all relevent peers. rosterGetStuff :: (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString]) - -> PresenceState -> ConnectionKey -> IO [Text] + -> PresenceState -> ClientAddress -> IO [Text] rosterGetStuff what state k = forClient state k (return []) $ \client -> do jids <- configText what (clientUser client) (clientProfile client) @@ -335,7 +338,7 @@ rosterGetStuff what state k = forClient state k (return []) -- Grok peers to associate with from the roster: forM_ hosts $ \host -> do -- We need either conns :: Connection.Manager TCPStatus Text - -- or toxman :: ToxManager ConnectionKey + -- or toxman :: ToxManager ClientAddress -- It is decided by checking hostnames for .tox ending. let policySetter = fromMaybe (Connection.setPolicy conns host) $ do toxman <- toxManager state @@ -346,17 +349,17 @@ rosterGetStuff what state k = forClient state k (return []) atomically $ putTMVar svVar (sv,conns) return jids -rosterGetBuddies :: PresenceState -> ConnectionKey -> IO [Text] +rosterGetBuddies :: PresenceState -> ClientAddress -> IO [Text] rosterGetBuddies state k = rosterGetStuff ConfigFiles.getBuddies state k -rosterGetSolicited :: PresenceState -> ConnectionKey -> IO [Text] +rosterGetSolicited :: PresenceState -> ClientAddress -> IO [Text] rosterGetSolicited = rosterGetStuff ConfigFiles.getSolicited -- XXX: Should we be connecting to these peers? -rosterGetOthers :: PresenceState -> ConnectionKey -> IO [Text] +rosterGetOthers :: PresenceState -> ClientAddress -> IO [Text] rosterGetOthers = rosterGetStuff ConfigFiles.getOthers -rosterGetSubscribers :: PresenceState -> ConnectionKey -> IO [Text] +rosterGetSubscribers :: PresenceState -> ClientAddress -> IO [Text] rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers data Conn = Conn { connChan :: TChan Stanza @@ -413,23 +416,20 @@ getBuddiesAndSolicited state pred -- of (Bool,Text) for processing outside. return (isbud,u,user,profile) -sendProbesAndSolicitations :: PresenceState - -> ConnectionKey -> SockAddr -> TChan Stanza -> IO () -sendProbesAndSolicitations state k laddr chan = do +sendProbesAndSolicitations :: PresenceState -> PeerAddress -> Local SockAddr -> TChan Stanza -> IO () +sendProbesAndSolicitations state k (Local laddr) chan = do -- get all buddies & solicited matching k for all users xs <- getBuddiesAndSolicited state $ \case h | ".tox" `Text.isSuffixOf` h -> return False -- Tox probes/solicitations are handled in ToxToXMPP module. h -> do addrs <- nub `fmap` resolvePeer h - case k of - ClientKey _ -> return False -- Solicitations and probes are only for peers. - PeerKey a -> return $ a `elem` addrs -- Only for this peer /k/. + return $ k `elem` addrs -- Only for this peer /k/. forM_ xs $ \(isbud,u,user,profile) -> do let make = if isbud then presenceProbe else presenceSolicitation toh = peerKeyToText k jid = unsplitJID (u,toh,Nothing) - me = addrToText laddr + me = addrToText laddr -- xmppTellMyNameToPeer from = if isbud then me -- probe from server else -- solicitation from particular user unsplitJID (Just user,me,Nothing) @@ -439,38 +439,35 @@ sendProbesAndSolicitations state k laddr chan = do atomically $ writeTChan chan stanza -- reverse xs `seq` return () -newConn :: PresenceState -> ConnectionKey -> ConnectionData -> TChan Stanza -> IO () -newConn state k cdta outchan = do - atomically $ modifyTVar' (keyToChan state) - $ Map.insert k Conn { connChan = outchan - , auxData = cdta } - when (isPeerKey k) - $ sendProbesAndSolicitations state k (cdAddr cdta) outchan + +newConn :: PresenceState -> 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) => - ConnectionKey -> m LocalPresence -> m LocalPresence + 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 -> ConnectionKey -> IO () -eofConn state k = do - atomically $ modifyTVar' (keyToChan state) $ Map.delete k - case k of - ClientKey {} -> 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) - PeerKey {} -> do +eofConn :: PresenceState -> SockAddr -> ConnectionData -> IO () +eofConn state saddr cdta = do + atomically $ case classifyConnection saddr cdta of + Left (pkey,_) -> modifyTVar' (pkeyToChan state) $ Map.delete pkey + Right (ckey,_) -> modifyTVar' (ckeyToChan state) $ Map.delete ckey + case classifyConnection saddr cdta of + Left (k,_) -> do let h = peerKeyToText k jids <- atomically $ do rbp <- readTVar (remotesByPeer state) @@ -482,29 +479,26 @@ eofConn state k = do 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) --- | 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) - fromMaybe (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)) +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 :: [Text] -> ConnectionKey -> IO Text -peerKeyToResolvedName buds k@(ClientKey { localAddress=addr }) = return "ErrorClIeNt1" +peerKeyToResolvedName :: [Text] -> PeerAddress -> IO Text peerKeyToResolvedName buds pk = do ns <- peerKeyToResolvedNames pk let hs = map (\jid -> let (_,h,_)=splitJID jid in h) buds @@ -512,27 +506,39 @@ peerKeyToResolvedName buds pk = do 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 :: Local SockAddr -> Text -> [Text] -> IO (Bool,(Maybe Text,Text,Maybe Text)) +rewriteJIDForClient (Local laddr) jid buds = do + let (n,h,r) = splitJID jid + 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 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 :: SockAddr -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)]) -multiplyJIDForClient laddr jid = do +multiplyJIDForClient :: ClientAddress -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)]) +multiplyJIDForClient k jid = do let (n,h,r) = splitJID jid maddr <- parseAddress (strip_brackets h) - fromMaybe (return (False,[(n,ip6literal h,r)])) $ maddr <&> \addr -> do - let mine = sameAddress laddr addr + 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 peerKeyToResolvedNames (PeerKey addr) + else peerKeyToResolvedNames (addrToPeerKey $ Remote saddr) 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 +guardPortStrippedAddress :: Text -> Local SockAddr -> IO (Maybe ()) +guardPortStrippedAddress h (Local laddr) = do maddr <- fmap (fmap (`withPort` 0)) $ parseAddress (strip_brackets h) let laddr' = laddr `withPort` 0 return $ maddr >>= guard . (==laddr') @@ -541,15 +547,15 @@ guardPortStrippedAddress h laddr = do -- | 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 +-- 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 :: Text -> IO (Maybe (Text,SockAddr)) +rewriteJIDForPeer :: Text -> IO (Maybe (Text,PeerAddress)) rewriteJIDForPeer jid = do let (n,h,r) = splitJID jid maddr <- fmap listToMaybe $ resolvePeer h return $ flip fmap maddr $ \addr -> - let h' = addrToText addr + let h' = peerKeyToText addr to' = unsplitJID (n,h',r) in (to',addr) @@ -567,14 +573,15 @@ deliverMessage :: PresenceState -> IO () deliverMessage state fail msg = case stanzaOrigin msg of - NetworkOrigin senderk@(ClientKey {}) _ -> do + ClientOrigin senderk _ -> do -- Case 1. Client -> Peer mto <- fmap join $ mapM rewriteJIDForPeer (stanzaTo msg) - fromMaybe fail {- reverse lookup failure -} $ mto <&> \(to',addr) -> do - let k = PeerKey addr - chans <- atomically $ readTVar (keyToChan state) - fromMaybe fail $ (Map.lookup k chans) <&> \(Conn { connChan = chan - , auxData = ConnectionData laddr ctyp }) -> do + fromMaybe fail {- reverse lookup failure -} $ mto <&> \(to',k) -> do + chans <- atomically $ readTVar (pkeyToChan state) + fromMaybe fail $ (Map.lookup k chans) <&> \Conn { connChan = chan + , auxData = ConnectionData (Left (Local laddr)) + ctyp + } -> do (n,r) <- forClient state senderk (return (Nothing,Nothing)) $ \c -> return (Just (clientUser c), Just (clientResource c)) -- original 'from' address is discarded. @@ -582,11 +589,14 @@ deliverMessage state fail msg = -- 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) - fromMaybe fail $ (Map.lookup senderk key_to_chan) + PeerOrigin senderk _ -> do + (pchans,cchans) <- atomically $ do + pc <- readTVar (pkeyToChan state) + cc <- readTVar (ckeyToChan state) + return (pc,cc) + fromMaybe fail $ (Map.lookup senderk pchans) <&> \(Conn { connChan = sender_chan - , auxData = ConnectionData laddr ctyp }) -> do + , auxData = ConnectionData (Left laddr) ctyp }) -> do fromMaybe fail $ (stanzaTo msg) <&> \to -> do (mine,(n,h,r)) <- rewriteJIDForClient laddr to [] if not mine then fail else do @@ -600,7 +610,7 @@ deliverMessage state fail msg = let ks = Map.keys (networkClients presence_container) chans = do (k,client) <- Map.toList $ networkClients presence_container - chan <- maybeToList $ Map.lookup k key_to_chan + chan <- maybeToList $ Map.lookup k cchans return (clientProfile client, clientUser client, chan) forM chans $ \(profile,user,chan) -> do buds <- configText ConfigFiles.getBuddies user profile @@ -642,7 +652,7 @@ deliverMessage state fail msg = chan -setClientFlag :: PresenceState -> ConnectionKey -> Int8 -> IO () +setClientFlag :: PresenceState -> ClientAddress -> Int8 -> IO () setClientFlag state k flag = atomically $ do cmap <- readTVar (clients state) @@ -653,12 +663,12 @@ setClientFlag0 :: ClientState -> Int8 -> STM () setClientFlag0 client flag = modifyTVar' (clientFlags client) (\flgs -> flgs .|. flag) -informSentRoster :: PresenceState -> ConnectionKey -> IO () +informSentRoster :: PresenceState -> ClientAddress -> IO () informSentRoster state k = do setClientFlag state k cf_interested -subscribedPeers :: Text -> Text -> IO [SockAddr] +subscribedPeers :: Text -> Text -> IO [PeerAddress] subscribedPeers user profile = do jids <- configText ConfigFiles.getSubscribers user profile let hosts = map ((\(_,h,_)->h) . splitJID) jids @@ -667,20 +677,23 @@ subscribedPeers user profile = do -- | this JID is suitable for peers, not clients. clientJID :: Conn -> ClientState -> Text clientJID con client = unsplitJID ( Just $ clientUser client - , addrToText $ cdAddr $ auxData con + , 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 - -> ConnectionKey -> StanzaWrap (LockedChan Event) -> IO () + -> ClientAddress -> 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 + -> Maybe ClientAddress -> ClientState -> StanzaWrap (LockedChan Event) -> IO () @@ -692,8 +705,8 @@ informClientPresence0 state mbk client stanza = do atomically $ setClientFlag0 client cf_available maybe (return ()) (sendCachedPresence state) mbk addrs <- subscribedPeers (clientUser client) (clientProfile client) - ktc <- atomically $ readTVar (keyToChan state) - let connected = mapMaybe (flip Map.lookup ktc . PeerKey) addrs + ktc <- atomically $ readTVar (pkeyToChan state) + let connected = mapMaybe (flip Map.lookup ktc) addrs forM_ connected $ \con -> do let from' = clientJID con client mto <- runTraversableT $ do @@ -706,7 +719,7 @@ informClientPresence0 state mbk client stanza = do (connChan con) informPeerPresence :: PresenceState - -> ConnectionKey + -> PeerAddress -> StanzaWrap (LockedChan Event) -> IO () informPeerPresence state k stanza = do @@ -749,7 +762,7 @@ informPeerPresence state k stanza = do -- all clients, we'll filter available/authorized later - ktc <- readTVar (keyToChan state) + ktc <- readTVar (ckeyToChan state) runTraversableT $ do (ck,client) <- liftMT $ fmap Map.toList $ readTVar (clients state) con <- liftMaybe $ Map.lookup ck ktc @@ -762,8 +775,7 @@ informPeerPresence state k stanza = do 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 + (_,trip) <- multiplyJIDForClient ck from return (map unsplitJID trip) putStrLn $ "sending to client: " ++ show (stanzaType stanza,froms) @@ -777,35 +789,37 @@ consoleClients PresenceState{ consoleWriter = Just cw } = readTVar (cwClients cw consoleClients _ = return Map.empty -answerProbe :: PresenceState - -> Maybe Text -> ConnectionKey -> TChan Stanza -> IO () +answerProbe :: PresenceState -> Maybe Text -> PeerAddress -> TChan Stanza -> IO () answerProbe state mto k chan = do -- putStrLn $ "answerProbe! " ++ show (stanzaType stanza) - (ktc,cmap) <- atomically $ (,) <$> readTVar (keyToChan state) - <*> readTVar (clients state) + ktc <- atomically $ readTVar (pkeyToChan 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 (cdAddr $ auxData conn) + Left laddr = cdAddr $ auxData conn + liftMT $ guardPortStrippedAddress h laddr u <- liftT mu - let ch = addrToText (cdAddr $ auxData conn) - profile = fromMaybe "." $ clientProfile <$> Map.lookup k cmap - return (u,profile,conn,ch) + -- ORIG let ch = addrToText (auxAddr conn) + -- ORIG return (u,conn,ch) + let ch = addrToText a where Local a = laddr + return (u,conn,ch) - forM_ muser $ \(u,profile,conn,ch) -> do + forM_ muser $ \(u,conn,ch) -> do + profiles <- releventProfiles (cdType $ auxData conn) u + forM_ profiles $ \profile -> do + + -- only subscribed peers should get probe replies resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u profile - let gaddrs = groupBy (\a b -> snd a == snd b) (sort resolved_subs) + let gaddrs = groupBy sameHost (sort resolved_subs) + sameHost a b = (snd a == snd b) -- (==) `on` snd 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 + 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 @@ -838,16 +852,15 @@ answerProbe state mto k chan = do -- Send friend requests and remote presences stored in remotesByPeer to XMPP -- clients. -sendCachedPresence :: PresenceState -> ConnectionKey -> IO () +sendCachedPresence :: PresenceState -> 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 hosts - let onlines = rbp `Map.intersection` Map.mapKeys PeerKey addrs - ClientKey laddr = k - mcon <- atomically $ do ktc <- readTVar (keyToChan state) + 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 @@ -855,7 +868,7 @@ sendCachedPresence state k = 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 + (mine,js) <- multiplyJIDForClient k jid forM_ js $ \jid -> do let from' = unsplitJID jid dup <- cloneStanza stanza @@ -883,7 +896,7 @@ addToRosterFile :: -> t1) -> Text -- user -> Text -- profile - -> Text -> [SockAddr] -> t1 + -> Text -> [PeerAddress] -> t1 addToRosterFile doit whose profile to addrs = modifyRosterFile doit whose profile to addrs True @@ -895,7 +908,7 @@ removeFromRosterFile :: -> t1) -> Text -- user -> Text -- profile - -> Text -> [SockAddr] -> t1 + -> Text -> [PeerAddress] -> t1 removeFromRosterFile doit whose profile to addrs = modifyRosterFile doit whose profile to addrs False @@ -920,7 +933,7 @@ modifyRosterFile :: -> Text -- ^ user -> Text -- ^ profile -> Text -- ^ JID that will be added or removed a hostname - -> [SockAddr] -- ^ Alias addresses for hostname in the JID. + -> [PeerAddress] -- ^ Alias addresses for hostname in the JID. -> Bool -- ^ True if adding, otherwise False -> t1 modifyRosterFile doit whose profile to addrs bAdd = do @@ -951,7 +964,7 @@ modifyRosterFile doit whose profile to addrs bAdd = do (guard bAdd >> Just (textToLazyByteString to)) -clientSubscriptionRequest :: PresenceState -> IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO () +clientSubscriptionRequest :: PresenceState -> 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 @@ -967,7 +980,7 @@ clientSubscriptionRequest state fail k stanza chan = do addToRosterFile ConfigFiles.modifySolicited cuser cprof to addrs removeFromRosterFile ConfigFiles.modifyBuddies cuser cprof to addrs resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers cuser cprof - let is_subscribed = not . null $ [ (mu, PeerKey a) | a <- addrs ] + let is_subscribed = not . null $ [ (mu, a) | a <- addrs ] `intersect` resolved_subs -- subscribers: "from" -- buddies: "to" @@ -975,16 +988,18 @@ clientSubscriptionRequest state fail k stanza chan = do case state of PresenceState { server = svVar } -> do - (ktc,(sv,conns)) <- atomically $ - liftM2 (,) (readTVar $ keyToChan state) - (takeTMVar svVar) + (cktc,pktc,(sv,conns)) <- atomically $ do + cktc <- readTVar $ ckeyToChan state + pktc <- readTVar $ pkeyToChan state + sc <- takeTMVar svVar + return (cktc,pktc,sc) -- 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 ktc (clientUser client) + chans <- clientCons state cktc (clientUser client) forM_ chans $ \( Conn { connChan=chan }, client ) -> do -- roster update ask="subscribe" update <- makeRosterUpdate cjid to @@ -996,13 +1011,13 @@ clientSubscriptionRequest state fail k stanza chan = do _ -> return () -- Send friend request to peer. - let dsts = ktc `Map.intersection` - Map.fromList [ (PeerKey a, ()) | a <- addrs ] + 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 from = unsplitJID ( Just $ clientUser client - , addrToText $ cdAddr $ auxData con + let Left laddr = cdAddr $ auxData con + from = unsplitJID ( Just $ clientUser client + , (\(Local a) -> addrToText a) $ laddr , Nothing ) mb <- rewriteJIDForPeer to forM_ mb $ \(to',addr) -> do @@ -1022,20 +1037,20 @@ clientSubscriptionRequest state fail k stanza chan = do resolvedFromRoster :: (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString]) - -> UserName -> Text -> IO [(Maybe UserName, ConnectionKey)] + -> UserName -> Text -> IO [(Maybe UserName, PeerAddress)] resolvedFromRoster doit u profile = do subs <- configText doit u profile runTraversableT $ do (mu,h,_) <- liftT $ splitJID `fmap` subs addr <- liftMT $ fmap nub $ resolvePeer h - return (mu,PeerKey addr) + return (mu,addr) clientCons :: PresenceState - -> Map ConnectionKey t -> Text -> IO [(t, ClientState)] + -> Map ClientAddress t -> Text -> IO [(t, ClientState)] clientCons state ktc u = map snd <$> clientCons' state ktc u clientCons' :: PresenceState - -> Map ConnectionKey t -> Text -> IO [(ConnectionKey,(t, ClientState))] + -> Map ClientAddress t -> Text -> IO [(ClientAddress,(t, ClientState))] clientCons' state ktc u = do mlp <- atomically $ do cmap <- readTVar $ clientsByUser state @@ -1047,7 +1062,14 @@ clientCons' state ktc u = do return (k,(con,client)) return $ mapMaybe doit ks -peerSubscriptionRequest :: PresenceState -> IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO () +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 -> IO () -> PeerAddress -> Stanza -> TChan Stanza -> IO () peerSubscriptionRequest state fail k stanza chan = do putStrLn $ "Handling pending subscription from remote" fromMaybe fail $ (stanzaFrom stanza) <&> \from -> do @@ -1056,24 +1078,20 @@ peerSubscriptionRequest state fail k stanza chan = do (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,cmap) <- atomically $ (,) <$> readTVar (keyToChan state) - <*> readTVar (clients state) - fromMaybe fail $ (Map.lookup k ktc) - <&> \Conn { auxData=ConnectionData laddr ctyp } -> do + (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 } -> do (mine,totup) <- rewriteJIDForClient laddr to [] if not mine then fail else do (_,fromtup) <- rewriteJIDForClient laddr from [] fromMaybe fail $ mto_u <&> \u -> do fromMaybe fail $ mfrom_u <&> \from_u -> do - let profile = fromMaybe "." $ clientProfile <$> Map.lookup k cmap - -- XXX profile is wrong. - -- TODO Likely the problem is that k is a peer ConnectionKey and of course - -- will have no entry in the cmap. Thus giving "." even though it ought - -- to be using a tox profile. - -- - -- Solution 1: Only .tox peers go in a tox profile. - -- Solution 2: Duplicate non .tox peers in all profiles. - -- Solution 3: Only one profile is active at a time. + profiles <- releventProfiles ctyp u + forM_ profiles $ \profile -> do resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u profile let already_subscribed = elem (mfrom_u,k) resolved_subs is_wanted = case stanzaType stanza of @@ -1116,7 +1134,7 @@ peerSubscriptionRequest state fail k stanza chan = do when (not already_pending) $ do -- contact ∉ subscribers & contact ∉ pending --> MUST - chans <- clientCons state ktc u + chans <- clientCons state cktc u forM_ chans $ \( Conn { connChan=chan }, client ) -> do -- send to clients -- TODO: interested/available clients only? @@ -1128,7 +1146,7 @@ peerSubscriptionRequest state fail k stanza chan = do clientInformSubscription :: PresenceState -> IO () - -> ConnectionKey + -> ClientAddress -> StanzaWrap (LockedChan Event) -> IO () clientInformSubscription state fail k stanza = do @@ -1139,7 +1157,7 @@ clientInformSubscription state fail k stanza = do addrs <- resolvePeer h -- remove from pending buds <- resolvedFromRoster ConfigFiles.getBuddies (clientUser client) (clientProfile client) - let is_buddy = not . null $ map ((mu,) . PeerKey) addrs `intersect` buds + let is_buddy = not . null $ map (mu,) addrs `intersect` buds removeFromRosterFile ConfigFiles.modifyPending (clientUser client) (clientProfile client) to addrs let (relationship,addf,remf) = case stanzaType stanza of @@ -1160,12 +1178,13 @@ clientInformSubscription state fail k stanza = do putStrLn $ "cbu = " ++ show (fmap (fmap clientPid . networkClients) cbu) -- send roster update to clients - (clients,ktc) <- atomically $ do + (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 (keyToChan state) - return (cs,ktc) + ktc <- readTVar (ckeyToChan state) + pktc <- readTVar (pkeyToChan state) + return (cs,ktc,pktc) forM_ clients $ \(ck, client) -> do is_intereseted <- atomically $ clientIsInterested client putStrLn $ "clientIsInterested: "++show is_intereseted @@ -1179,8 +1198,8 @@ clientInformSubscription state fail k stanza = do sendModifiedStanzaToClient update (connChan con) -- notify peer - let dsts = Map.fromList $ map ((,()) . PeerKey) addrs - cdsts = ktc `Map.intersection` dsts + 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) @@ -1192,18 +1211,21 @@ clientInformSubscription state fail k stanza = do peerInformSubscription :: PresenceState -> IO () - -> ConnectionKey + -> PeerAddress -> StanzaWrap (LockedChan Event) -> IO () peerInformSubscription state fail k stanza = do putStrLn $ "TODO: peerInformSubscription" -- remove from solicited fromMaybe fail $ (stanzaFrom stanza) <&> \from -> do - (ktc,cmap) <- atomically $ (,) <$> readTVar (keyToChan state) - <*> readTVar (clients state) + (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 laddr ctyp }) -> do + , auxData =ConnectionData (Left laddr) ctyp }) -> do (_,(from_u,from_h,_)) <- rewriteJIDForClient laddr from [] let from'' = unsplitJID (from_u,from_h,Nothing) muser = do @@ -1215,10 +1237,11 @@ peerInformSubscription state fail k stanza = do -- This would allow us to answer anonymous probes with 'unsubscribed'. fromMaybe fail $ muser <&> \user -> do addrs <- resolvePeer from_h - let profile = fromMaybe "." $ clientProfile <$> Map.lookup k cmap + profiles <- releventProfiles ctyp user + forM_ profiles $ \profile -> do was_solicited <- removeFromRosterFile ConfigFiles.modifySolicited user profile from'' addrs subs <- resolvedFromRoster ConfigFiles.getSubscribers user profile - let is_sub = not . null $ map ((from_u,) . PeerKey) addrs `intersect` subs + let is_sub = not . null $ map (from_u,) addrs `intersect` subs putStrLn $ "DEBUG peerInformSubscription (is_sub,typ)=" ++ show (is_sub,stanzaType stanza) let (relationship,addf,remf) = case stanzaType stanza of @@ -1234,7 +1257,7 @@ peerInformSubscription state fail k stanza = do addToRosterFile addf user profile from'' addrs removeFromRosterFile remf user profile from'' addrs - chans <- clientCons' state ktc user + chans <- clientCons' state cktc user forM_ chans $ \(ckey,(Conn { connChan=chan }, client)) -> do hostname <- nameForClient state ckey let to' = unsplitJID (Just user, hostname, Nothing) -- cgit v1.2.3