From 8413039df93b239ea3fcadc1872277201c1b5399 Mon Sep 17 00:00:00 2001 From: joe Date: Mon, 20 Nov 2017 21:07:16 -0500 Subject: WIP: Multiple identities/rosters for a single unix user. --- Presence/ClientState.hs | 15 +++- Presence/ConfigFiles.hs | 111 ++++++++++++++---------- Presence/ConsoleWriter.hs | 17 ++-- Presence/Presence.hs | 213 ++++++++++++++++++++++++++++------------------ Presence/XMPPServer.hs | 65 +++++++------- 5 files changed, 250 insertions(+), 171 deletions(-) (limited to 'Presence') diff --git a/Presence/ClientState.hs b/Presence/ClientState.hs index 30a53131..08cc54ed 100644 --- a/Presence/ClientState.hs +++ b/Presence/ClientState.hs @@ -9,11 +9,18 @@ import UTmp ( ProcessID ) import XMPPServer ( Stanza ) data ClientState = ClientState + -- | The unix tty or the jabber resource for this client. { clientResource :: Text - , clientUser :: Text - , clientPid :: Maybe ProcessID - , clientStatus :: TVar (Maybe Stanza) - , clientFlags :: TVar Int8 + -- | Unix user that is running this client. + , clientUser :: Text + -- | The specific roster/identity of the user that this client presenting. + , clientProfile :: Text + -- | The unix process id of the client if we know it. + , clientPid :: Maybe ProcessID + -- | The presence (away/available) stanza this client is indicating. + , clientStatus :: TVar (Maybe Stanza) + -- | XMPP client flags (read access via 'clientIsAvailable' and 'clientIsInterested') + , clientFlags :: TVar Int8 } cf_available :: Int8 diff --git a/Presence/ConfigFiles.hs b/Presence/ConfigFiles.hs index 808e6dd8..b745094f 100644 --- a/Presence/ConfigFiles.hs +++ b/Presence/ConfigFiles.hs @@ -18,32 +18,42 @@ import Data.List (partition) import Data.Maybe (catMaybes,isJust) type User = ByteString +type Profile = String -configDir = ".presence" -buddyFile = "buddies" +configDir, buddyFile, subscriberFile, + otherFile, pendingFile, solicitedFile, + secretsFile :: FilePath + +configDir = ".presence" +buddyFile = "buddies" subscriberFile = "subscribers" -otherFile = "others" -pendingFile = "pending" -solicitedFile = "solicited" +otherFile = "others" +pendingFile = "pending" +solicitedFile = "solicited" +secretsFile = "secrets" -configPath :: User -> String -> IO String -configPath user filename = do +configPath :: User -> Profile -> String -> IO String +configPath user "." filename = do ue <- getUserEntryForName (unpack user) return $ (++("/"++configDir++"/"++filename)) $ homeDirectory ue +configPath user profile filename = do + ue <- getUserEntryForName (unpack user) + return $ (++("/"++configDir++"/"++profile++"/"++filename)) $ homeDirectory ue - +createConfigFile :: ByteString -> FilePath -> IO () createConfigFile tag path = do let dir = dropFileName path doesDirectoryExist dir >>= flip unless (do - createDirectory dir + createDirectory dir ) withFile path WriteMode $ \h -> do L.hPutStrLn h tag +addItem :: ByteString -> ByteString -> FilePath -> IO () addItem item tag path = let doit = do - handle (\e -> when (isDoesNotExistError e) + handle (\e -> when (isDoesNotExistError e) (createConfigFile tag path >> doit)) $ do exists <- fileExist path if exists @@ -55,16 +65,27 @@ addItem item tag path = in doit +-- | Modify a presence configuration file. This function will iterate over all +-- items in the file and invoke a test function. If the function returns +-- Nothing, that item is removed from the file. Otherwise, the function may +-- rename the item by returning the new name. +-- +-- If the last argument is populated, it is a new item to append to the end of +-- the file. +-- +-- Note that the entire file is read in, processed, and then rewritten from +-- scratch. modifyFile :: (ByteString,FilePath) - -> ByteString - -> (ByteString -> IO (Maybe ByteString)) - -> Maybe ByteString + -> User + -> Profile + -> (ByteString -> IO (Maybe ByteString)) -- Returns Just for each item you want to keep. + -> Maybe ByteString -- Optionally append this item. -> IO Bool -- Returns True if test function ever returned Nothing -modifyFile (tag,file) user test appending = configPath user file >>= doit +modifyFile (tag,file) user profile test appending = configPath user profile file >>= doit where doit path = do - handle (\e -> if (isDoesNotExistError e) + handle (\e -> if (isDoesNotExistError e) then (createConfigFile tag path >> doit path) else return False) $ do exists <- fileExist path @@ -85,46 +106,48 @@ modifyFile (tag,file) user test appending = configPath user file >>= doit withFile path WriteMode $ \h -> do L.hPutStrLn h tag withJust appending (L.hPutStrLn h) - return False - + return False -modifySolicited = modifyFile ("" , solicitedFile) -modifyBuddies = modifyFile ("" , buddyFile) -modifyOthers = modifyFile ("" , otherFile) -modifyPending = modifyFile ("" , pendingFile) -modifySubscribers = modifyFile ("", subscriberFile) +modifySolicited, modifyBuddies, modifyOthers, modifyPending, modifySubscribers + :: User -> Profile -> (ByteString -> IO (Maybe ByteString)) -> Maybe ByteString -> IO Bool -addBuddy :: User -> ByteString -> IO () -addBuddy user buddy = - configPath user buddyFile >>= addItem buddy "" +modifySolicited = modifyFile ("" , solicitedFile) +modifyBuddies = modifyFile ("" , buddyFile) +modifyOthers = modifyFile ("" , otherFile) +modifyPending = modifyFile ("" , pendingFile) +modifySubscribers = modifyFile ("" , subscriberFile) -addSubscriber :: User -> ByteString -> IO () -addSubscriber user subscriber = - configPath user subscriberFile >>= addItem subscriber "" +addBuddy :: User -> Profile -> ByteString -> IO () +addBuddy user profile buddy = + configPath user profile buddyFile >>= addItem buddy "" -addSolicited :: User -> ByteString -> IO () -addSolicited user solicited = - configPath user solicitedFile >>= addItem solicited "" +addSubscriber :: User -> Profile -> ByteString -> IO () +addSubscriber user profile subscriber = + configPath user profile subscriberFile >>= addItem subscriber "" +addSolicited :: User -> Profile -> ByteString -> IO () +addSolicited user profile solicited = + configPath user profile solicitedFile >>= addItem solicited "" -getConfigList path = +getConfigList :: FilePath -> IO [ByteString] +getConfigList path = handle (\e -> if isDoesNotExistError e then (return []) else throw e) $ withFile path ReadMode $ - L.hGetContents - >=> return . Prelude.tail . L.lines + L.hGetContents + >=> return . Prelude.tail . L.lines >=> (\a -> seq (rnf a) (return a)) -getBuddies :: User -> IO [ByteString] -getBuddies user = configPath user buddyFile >>= getConfigList +getBuddies :: User -> Profile -> IO [ByteString] +getBuddies user profile = configPath user profile buddyFile >>= getConfigList -getSubscribers :: User -> IO [ByteString] -getSubscribers user = configPath user subscriberFile >>= getConfigList +getSubscribers :: User -> Profile -> IO [ByteString] +getSubscribers user profile = configPath user profile subscriberFile >>= getConfigList -getOthers :: User -> IO [ByteString] -getOthers user = configPath user otherFile >>= getConfigList +getOthers :: User -> Profile -> IO [ByteString] +getOthers user profile = configPath user profile otherFile >>= getConfigList -getPending :: User -> IO [ByteString] -getPending user = configPath user pendingFile >>= getConfigList +getPending :: User -> Profile -> IO [ByteString] +getPending user profile = configPath user profile pendingFile >>= getConfigList -getSolicited :: User -> IO [ByteString] -getSolicited user = configPath user solicitedFile >>= getConfigList +getSolicited :: User -> Profile -> IO [ByteString] +getSolicited user profile = configPath user profile solicitedFile >>= getConfigList diff --git a/Presence/ConsoleWriter.hs b/Presence/ConsoleWriter.hs index 986294f4..b80e477a 100644 --- a/Presence/ConsoleWriter.hs +++ b/Presence/ConsoleWriter.hs @@ -100,8 +100,8 @@ onLogin cs start = \e -> do $ \tuvar -> do tu <- readTVar tuvar return (tty,tu) - - forM_ (Map.elems newborn) $ + + forM_ (Map.elems newborn) $ forkIO . start getActive -- forM_ (Map.elems dead ) $ putStrLn . ("gone: "++) . show @@ -297,7 +297,7 @@ writeAllPty cw msg = do && Text.all isDigit (Text.drop 4 k) bs <- forM (Map.toList ptys) $ \(tty,utmp) -> do deliverTerminalMessage cw ("/dev/" <> tty) utmp msg - return $ or bs + return $ or bs resource :: UtmpRecord -> Text resource u = @@ -341,10 +341,11 @@ newCon log cw activeTTY utmp = do statusv <- atomically $ newTVar (Just stanza) flgs <- atomically $ newTVar 0 let client = ClientState { clientResource = r - , clientUser = utmpUser u - , clientPid = Nothing - , clientStatus = statusv - , clientFlags = flgs } + , clientUser = utmpUser u + , clientProfile = "." + , clientPid = Nothing + , clientStatus = statusv + , clientFlags = flgs } atomically $ do modifyTVar (cwClients cw) $ Map.insert r client putTMVar (cwPresenceChan cw) (client,stanza) @@ -359,7 +360,7 @@ newCon log cw activeTTY utmp = do guard (not $ Text.null $ utmpHost tu) return tu match mtu = searchstr mtu `Text.isInfixOf` Text.dropWhile (/=':') r - jstatus r ttynum tu = + jstatus r ttynum tu = if bstatus r ttynum tu then Available else Away diff --git a/Presence/Presence.hs b/Presence/Presence.hs index 15775857..9b91dc1d 100644 --- a/Presence/Presence.hs +++ b/Presence/Presence.hs @@ -32,7 +32,7 @@ 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.Maybe import Data.Bits import Data.Int (Int8) import Data.XML.Types (Event) @@ -56,10 +56,12 @@ 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 +localJID :: Text -> Text -> Text -> IO Text +localJID user "." resource = do hostname <- textHostName return $ user <> "@" <> hostname <> "/" <> resource +localJID user profile resource = + return $ user <> "@" <> profile <> "/" <> resource data PresenceState = forall status. PresenceState { clients :: TVar (Map ConnectionKey ClientState) @@ -72,6 +74,9 @@ data PresenceState = forall status. PresenceState } +newPresenceState :: Maybe ConsoleWriter + -> TMVar (XMPPServer, Connection.Manager status Text) + -> IO PresenceState newPresenceState cw xmpp = atomically $ do clients <- newTVar Map.empty clientsByUser <- newTVar Map.empty @@ -87,6 +92,7 @@ newPresenceState cw xmpp = atomically $ do } +presenceHooks :: PresenceState -> Int -> XMPPServerParameters presenceHooks state verbosity = XMPPServerParameters { xmppChooseResourceName = chooseResourceName state , xmppTellClientHisName = tellClientHisName state @@ -165,21 +171,25 @@ identifyTTY' ttypids uid inode = ttypid textify (tty,pid) = (fmap lazyByteStringToText tty, pid) chooseResourceName :: PresenceState - -> ConnectionKey -> SockAddr -> t -> IO Text -chooseResourceName state k addr desired = do + -> ConnectionKey -> SockAddr -> Maybe Text -> Maybe Text -> IO Text +chooseResourceName state k 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 $ \wanted_profile -> do + -- TODO: allow user to select profile + return "." let client = ClientState { clientResource = maybe "fallback" id mtty - , clientUser = user - , clientPid = pid - , clientStatus = status - , clientFlags = flgs } + , 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) + buds <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client) forM_ buds $ \bud -> do let (_,h,_) = splitJID bud forkIO $ void $ resolvePeer h @@ -191,7 +201,7 @@ chooseResourceName state k addr desired = do (pcInsertNetworkClient k client) mb - localJID (clientUser client) (clientResource client) + localJID (clientUser client) (clientProfile client) (clientResource client) where getTTYandPID muid = do @@ -226,8 +236,8 @@ forClient state k fallback f = do 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) + 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 @@ -237,11 +247,11 @@ resolveAllPeers hosts = fmap (toMapUnit . concat) $ Prelude.mapM (fmap (take 1) rosterGetStuff - :: (L.ByteString -> IO [L.ByteString]) + :: (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString]) -> PresenceState -> ConnectionKey -> IO [Text] rosterGetStuff what state k = forClient state k (return []) $ \client -> do - jids <- configText what (clientUser client) + jids <- configText what (clientUser client) (clientProfile client) let hosts = map ((\(_,h,_)->h) . splitJID) jids case state of PresenceState { server = svVar } -> do @@ -267,13 +277,16 @@ 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] + (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 -> IO [Text] +getSolicited' :: Text -> Text -> IO [Text] getSolicited' = configText ConfigFiles.getSolicited sendProbesAndSolicitations :: PresenceState @@ -282,10 +295,11 @@ 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 + (user,LocalPresence cmap) <- liftT $ Map.toList cbu + profile <- liftT $ nub $ map clientProfile $ Map.elems cmap (isbud,getter) <- liftT [(True ,getBuddies' ) ,(False,getSolicited')] - bud <- liftMT $ getter user + bud <- liftMT $ getter user profile let (u,h,r) = splitJID bud addr <- liftMT $ nub `fmap` resolvePeer h liftT $ guard (PeerKey addr == k) @@ -294,10 +308,10 @@ sendProbesAndSolicitations state k laddr chan = do -- 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) + return (isbud,u,user,profile) -- XXX: The following O(n²) nub may be a little -- too onerous. - forM_ (nub xs) $ \(isbud,u,user) -> do + forM_ (nub xs) $ \(isbud,u,user,profile) -> do let make = if isbud then presenceProbe else presenceSolicitation toh = peerKeyToText k @@ -378,13 +392,17 @@ rewriteJIDForClient laddr jid buds = do else peerKeyToResolvedName buds (PeerKey addr) return (mine,(n,h',r)) +-- 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 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') + return $ fromMaybe (peerKeyToText pk) (listToMaybe ns') multiplyJIDForClient :: SockAddr -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)]) @@ -468,33 +486,46 @@ deliverMessage state fail msg = 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 + chans <- fmap (fromMaybe []) $ do + forM (n >>= 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 key_to_chan + return (clientProfile client, chan) + forM chans $ \(profile,chan) -> do + buds <- configText ConfigFiles.getBuddies (fromJust n) profile 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) + return (from',chan) 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 + if null chans then 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 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 -> ConnectionKey -> Int8 -> IO () @@ -513,9 +544,9 @@ informSentRoster state k = do setClientFlag state k cf_interested -subscribedPeers :: Text -> IO [SockAddr] -subscribedPeers user = do - jids <- configText ConfigFiles.getSubscribers user +subscribedPeers :: Text -> Text -> IO [SockAddr] +subscribedPeers user profile = do + jids <- configText ConfigFiles.getSubscribers user profile let hosts = map ((\(_,h,_)->h) . splitJID) jids fmap Map.keys $ resolveAllPeers hosts @@ -546,7 +577,7 @@ informClientPresence0 state mbk client stanza = do when (not is_avail) $ do atomically $ setClientFlag0 client cf_available maybe (return ()) (sendCachedPresence state) mbk - addrs <- subscribedPeers (clientUser client) + addrs <- subscribedPeers (clientUser client) (clientProfile client) ktc <- atomically $ readTVar (keyToChan state) let connected = mapMaybe (flip Map.lookup ktc . PeerKey) addrs forM_ connected $ \con -> do @@ -649,7 +680,7 @@ answerProbe state mto k chan = do flip (maybe $ return ()) muser $ \(u,conn,ch) -> do - resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u + resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u (_todo {- profile -}) let gaddrs = groupBy (\a b -> snd a == snd b) (sort resolved_subs) whitelist = do xs <- gaddrs @@ -693,7 +724,7 @@ 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) + 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 @@ -714,7 +745,7 @@ sendCachedPresence state k = do sendModifiedStanzaToClient (dup { stanzaFrom=Just from' }) (connChan con) - pending <- configText ConfigFiles.getPending (clientUser client) + pending <- configText ConfigFiles.getPending (clientUser client) (clientProfile client) hostname <- textHostName forM_ pending $ \pending_jid -> do let cjid = unsplitJID ( Just $ clientUser client @@ -728,27 +759,39 @@ sendCachedPresence state k = do return () addToRosterFile :: (MonadPlus t, Traversable t) => - (L.ByteString -> (L.ByteString -> IO (t L.ByteString)) + (ConfigFiles.User + -> ConfigFiles.Profile + -> (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 + -> Text -- user + -> Text -- profile + -> Text -> [SockAddr] -> t1 +addToRosterFile doit whose profile to addrs = + modifyRosterFile doit whose profile to addrs True removeFromRosterFile :: (MonadPlus t, Traversable t) => - (L.ByteString -> (L.ByteString -> IO (t L.ByteString)) + (ConfigFiles.User + -> ConfigFiles.Profile + -> (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 + -> Text -- user + -> Text -- profile + -> Text -> [SockAddr] -> t1 +removeFromRosterFile doit whose profile to addrs = + modifyRosterFile doit whose profile to addrs False modifyRosterFile :: (Traversable t, MonadPlus t) => - (L.ByteString -> (L.ByteString -> IO (t L.ByteString)) + (ConfigFiles.User + -> ConfigFiles.Profile + -> (L.ByteString -> IO (t L.ByteString)) -> Maybe L.ByteString -> t1) - -> Text -> Text -> [SockAddr] -> Bool -> t1 -modifyRosterFile doit whose to addrs bAdd = do + -> Text -- user + -> Text -- profile + -> Text -> [SockAddr] -> Bool -> t1 +modifyRosterFile doit whose profile to addrs bAdd = do let (mu,_,_) = splitJID to cmp jid = runTraversableT $ do let (msu,stored_h,mr) = splitJID (lazyByteStringToText jid) @@ -767,7 +810,7 @@ modifyRosterFile doit whose to addrs bAdd = do if null (stored_addrs \\ addrs) then mzero else do -- keep return jid - doit (textToLazyByteString whose) + doit (textToLazyByteString whose) (Text.unpack profile) cmp (guard bAdd >> Just (textToLazyByteString to)) @@ -781,9 +824,9 @@ clientSubscriptionRequest state fail k stanza chan = do flip (maybe fail) mu $ \u -> do -- add to-address to from's solicited addrs <- resolvePeer h - addToRosterFile ConfigFiles.modifySolicited (clientUser client) to addrs - removeFromRosterFile ConfigFiles.modifyBuddies (clientUser client) to addrs - resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers (clientUser client) + addToRosterFile ConfigFiles.modifySolicited (clientUser client) (clientProfile client) to addrs + removeFromRosterFile ConfigFiles.modifyBuddies (clientUser client) (clientProfile client) to addrs + resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers (clientUser client) (clientProfile client) let is_subscribed = not . null $ intersect (map ((mu,).PeerKey) addrs) resolved_subs -- subscribers: "from" -- buddies: "to" @@ -831,10 +874,10 @@ clientSubscriptionRequest state fail k stanza chan = do resolvedFromRoster - :: (L.ByteString -> IO [L.ByteString]) - -> UserName -> IO [(Maybe UserName, ConnectionKey)] -resolvedFromRoster doit u = do - subs <- configText doit u + :: (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString]) + -> UserName -> Text -> IO [(Maybe UserName, ConnectionKey)] +resolvedFromRoster doit u profile = do + subs <- configText doit u profile runTraversableT $ do (mu,h,_) <- liftT $ splitJID `fmap` subs addr <- liftMT $ fmap nub $ resolvePeer h @@ -870,7 +913,7 @@ peerSubscriptionRequest state fail k stanza chan = 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 + resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u (_todo {- profile -}) let already_subscribed = elem (mfrom_u,k) resolved_subs is_wanted = case stanzaType stanza of PresenceRequestSubscription b -> b @@ -900,9 +943,9 @@ peerSubscriptionRequest state fail k stanza chan = do already_pending <- if is_wanted then - addToRosterFile ConfigFiles.modifyPending u from' addrs + addToRosterFile ConfigFiles.modifyPending u (_todo {- profile -}) from' addrs else do - removeFromRosterFile ConfigFiles.modifySubscribers u from' addrs + removeFromRosterFile ConfigFiles.modifySubscribers u (_todo {- profile -}) from' addrs reply <- makeInformSubscription "jabber:server" to from is_wanted sendModifiedStanzaToPeer reply chan return False @@ -933,9 +976,9 @@ clientInformSubscription state fail k stanza = do let (mu,h,mr) = splitJID to addrs <- resolvePeer h -- remove from pending - buds <- resolvedFromRoster ConfigFiles.getBuddies (clientUser client) + buds <- resolvedFromRoster ConfigFiles.getBuddies (clientUser client) (clientProfile client) let is_buddy = not . null $ map ((mu,) . PeerKey) addrs `intersect` buds - removeFromRosterFile ConfigFiles.modifyPending (clientUser client) to addrs + removeFromRosterFile ConfigFiles.modifyPending (clientUser client) (clientProfile client) to addrs let (relationship,addf,remf) = case stanzaType stanza of PresenceInformSubscription True -> @@ -947,8 +990,8 @@ clientInformSubscription state fail k stanza = do else "none" ) , ConfigFiles.modifyOthers , ConfigFiles.modifySubscribers ) - addToRosterFile addf (clientUser client) to addrs - removeFromRosterFile remf (clientUser client) to addrs + addToRosterFile addf (clientUser client) (clientProfile client) to addrs + removeFromRosterFile remf (clientUser client) (clientProfile client) to addrs do cbu <- atomically $ readTVar (clientsByUser state) @@ -1009,8 +1052,8 @@ peerInformSubscription state fail k stanza = do -- 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 + was_solicited <- removeFromRosterFile ConfigFiles.modifySolicited user (_todo {- profile -}) from'' addrs + subs <- resolvedFromRoster ConfigFiles.getSubscribers user (_todo {- profile -}) let is_sub = not . null $ map ((from_u,) . PeerKey) addrs `intersect` subs let (relationship,addf,remf) = case stanzaType stanza of @@ -1023,8 +1066,8 @@ peerInformSubscription state fail k stanza = do else "none") , ConfigFiles.modifyOthers , ConfigFiles.modifyBuddies ) - addToRosterFile addf user from'' addrs - removeFromRosterFile remf user from'' addrs + addToRosterFile addf user (_todo {- profile -}) from'' addrs + removeFromRosterFile remf user (_todo {- profile -}) from'' addrs hostname <- textHostName let to' = unsplitJID (Just user, hostname, Nothing) diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs index 5a0ed20e..6f4a191b 100644 --- a/Presence/XMPPServer.hs +++ b/Presence/XMPPServer.hs @@ -134,7 +134,7 @@ data StanzaType = Unrecognized | Ping | Pong - | RequestResource (Maybe Text) + | RequestResource (Maybe Text) (Maybe Text) -- ^ Client's name for this host followed by client's requested resource id. | SetResource | SessionRequest | UnrecognizedQuery Name @@ -179,39 +179,40 @@ type Stanza = StanzaWrap (LockedChan XML.Event) data XMPPServerParameters = XMPPServerParameters - { -- | Called when a client requests a resource id. The Maybe value is the - -- client's preference. - xmppChooseResourceName :: ConnectionKey -> SockAddr -> Maybe Text -> IO Text + { -- | Called when a client requests a resource id. The first Maybe indicates + -- the name the client referred to this server by. The second Maybe is the + -- client's preferred resource name. + xmppChooseResourceName :: ConnectionKey -> SockAddr -> Maybe Text -> Maybe Text -> IO Text , -- | This should indicate the server's hostname that all client's see. xmppTellMyNameToClient :: IO Text - , xmppTellMyNameToPeer :: SockAddr -> IO Text - , xmppTellClientHisName :: ConnectionKey -> IO Text - , xmppTellPeerHisName :: ConnectionKey -> IO Text - , xmppNewConnection :: ConnectionKey -> SockAddr -> TChan Stanza -> IO () - , xmppEOF :: ConnectionKey -> IO () + , xmppTellMyNameToPeer :: SockAddr -> IO Text + , xmppTellClientHisName :: ConnectionKey -> IO Text + , xmppTellPeerHisName :: ConnectionKey -> IO Text + , xmppNewConnection :: ConnectionKey -> SockAddr -> TChan Stanza -> IO () + , xmppEOF :: ConnectionKey -> IO () , xmppRosterBuddies :: ConnectionKey -> IO [Text] , xmppRosterSubscribers :: ConnectionKey -> IO [Text] , xmppRosterSolicited :: ConnectionKey -> IO [Text] , xmppRosterOthers :: ConnectionKey -> IO [Text] , -- | Called when after sending a roster to a client. Usually this means -- the client status should change from "available" to "interested". - xmppSubscribeToRoster :: ConnectionKey -> IO () + xmppSubscribeToRoster :: ConnectionKey -> IO () -- , xmppLookupClientJID :: ConnectionKey -> IO Text , xmppTellClientNameOfPeer :: ConnectionKey -> [Text] -> IO Text - , xmppDeliverMessage :: (IO ()) -> Stanza -> IO () + , xmppDeliverMessage :: (IO ()) -> Stanza -> IO () -- | Called whenever a local client's presence changes. , xmppInformClientPresence :: ConnectionKey -> Stanza -> IO () -- | Called whenever a remote peer's presence changes. , xmppInformPeerPresence :: ConnectionKey -> Stanza -> IO () , -- | Called when a remote peer requests our status. - xmppAnswerProbe :: ConnectionKey -> Stanza -> TChan Stanza -> IO () + xmppAnswerProbe :: ConnectionKey -> Stanza -> TChan Stanza -> IO () , xmppClientSubscriptionRequest :: IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO () , -- | Called when a remote peer sends subscription request. xmppPeerSubscriptionRequest :: IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO () , xmppClientInformSubscription :: IO () -> ConnectionKey -> Stanza -> IO () , -- | Called when a remote peer informs us of our subscription status. xmppPeerInformSubscription :: IO () -> ConnectionKey -> Stanza -> IO () - , xmppVerbosity :: IO Int + , xmppVerbosity :: IO Int } @@ -584,9 +585,9 @@ grokStanzaIQSet stanza = do case fmap tagName mchild of Just "{urn:ietf:params:xml:ns:xmpp-bind}resource" -> do rsc <- XML.content -- TODO: MonadThrow??? - return . Just $ RequestResource (Just rsc) + return . Just $ RequestResource Nothing (Just rsc) Just _ -> return Nothing - Nothing -> return . Just $ RequestResource Nothing + Nothing -> return . Just $ RequestResource Nothing Nothing "{urn:ietf:params:xml:ns:xmpp-session}session" -> do return $ Just SessionRequest _ -> return Nothing @@ -886,10 +887,10 @@ xmppInbound :: Server ConnectionKey SockAddr ReleaseKey XML.Event -> XMPPServerParameters -> ConnectionKey -> SockAddr - -> FlagCommand -- ^ action to check whether the connection needs a ping - -> TChan Stanza -- ^ channel to announce incomming stanzas on + -> FlagCommand -- ^ action to check whether the connection needs a ping + -> TChan Stanza -- ^ channel to announce incoming stanzas on -> TChan Stanza -- ^ channel used to send stanzas - -> TMVar () -- ^ mvar that is filled when the connection quits + -> TMVar () -- ^ mvar that is filled when the connection quits -> Sink XML.Event IO () xmppInbound sv xmpp k laddr pingflag stanzas output donevar = doNestingXML $ do let (namespace,tellmyname,tellyourname) = case k of @@ -906,6 +907,9 @@ xmppInbound sv xmpp k laddr pingflag stanzas output donevar = doNestingXML $ do when (begindoc==EventBeginDocument) $ do whenJust nextElement $ \xml -> do withJust (elementAttrs "stream" xml) $ \stream_attrs -> do + -- liftIO $ hPutStrLn stderr $ "STREAM ATTRS "++show stream_attrs + let stream_name = lookupAttrib "to" stream_attrs + -- xmpp_version = lookupAttrib "version" stream_attrs fix $ \loop -> do -- liftIO . wlog $ "waiting for stanza." (chan,clsrs) <- liftIO . atomically $ @@ -916,9 +920,9 @@ xmppInbound sv xmpp k laddr pingflag stanzas output donevar = doNestingXML $ do writeLChan chan stanzaTag modifyTVar' clsrs (fmap (closerFor stanzaTag:)) copyToChannel id chan clsrs =$= do - let mid = lookupAttrib "id" (tagAttrs stanzaTag) - mfrom = lookupAttrib "from" (tagAttrs stanzaTag) - mto = lookupAttrib "to" (tagAttrs stanzaTag) + let mid = lookupAttrib "id" $ tagAttrs stanzaTag + mfrom = lookupAttrib "from" $ tagAttrs stanzaTag + mto = lookupAttrib "to" $ tagAttrs stanzaTag dispatch <- grokStanza namespace stanzaTag let unrecog = do let stype = Unrecognized @@ -960,14 +964,15 @@ xmppInbound sv xmpp k laddr pingflag stanzas output donevar = doNestingXML $ do } #endif stype -> ioWriteChan stanzas Stanza - { stanzaType = stype - , stanzaId = mid - , stanzaTo = mto - , stanzaFrom = mfrom - , stanzaChan = chan - , stanzaClosers = clsrs + { stanzaType = case stype of + RequestResource _ rsc -> RequestResource stream_name rsc + , stanzaId = mid + , stanzaTo = mto + , stanzaFrom = mfrom + , stanzaChan = chan + , stanzaClosers = clsrs , stanzaInterrupt = donevar - , stanzaOrigin = NetworkOrigin k output + , stanzaOrigin = NetworkOrigin k output } awaitCloser stanza_lvl liftIO . atomically $ writeTVar clsrs Nothing @@ -1670,9 +1675,9 @@ monitor sv params xmpp = do case stanzaOrigin stanza of NetworkOrigin k@(ClientKey {}) replyto -> case stanzaType stanza of - RequestResource wanted -> do + RequestResource clientsNameForMe wanted -> do sockaddr <- socketFromKey sv k - rsc <- xmppChooseResourceName xmpp k sockaddr wanted + rsc <- xmppChooseResourceName xmpp k sockaddr clientsNameForMe wanted let reply = iq_bind_reply (stanzaId stanza) rsc -- sendReply quitVar SetResource reply replyto hostname <- xmppTellMyNameToClient xmpp -- cgit v1.2.3