From 79117606dc8f4a37a56493cf441a1ca841475fd3 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 19 Mar 2013 19:28:40 +0100 Subject: [PATCH] add roster handling --- source/Network/Xmpp/IM/Roster.hs | 170 +++++++++++++++++++++++++++++++ 1 file changed, 170 insertions(+) create mode 100644 source/Network/Xmpp/IM/Roster.hs diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs new file mode 100644 index 0000000..1f359f9 --- /dev/null +++ b/source/Network/Xmpp/IM/Roster.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.Xmpp.IM.Roster +where + +import Control.Concurrent.STM +import Control.Monad +import Data.Text (Text) +import Data.XML.Pickle +import Data.XML.Types +import Network.Xmpp +import Network.Xmpp.Marshal +import System.Log.Logger +import qualified Data.Map.Strict as Map + +import Network.Xmpp.Types + +data Subscription = None | To | From | Both | Remove deriving Eq + +instance Show Subscription where + show None = "none" + show To = "to" + show From = "from" + show Both = "both" + show Remove = "remove" + +instance Read Subscription where + readsPrec _ "none" = [(None ,"")] + readsPrec _ "to" = [(To ,"")] + readsPrec _ "from" = [(From ,"")] + readsPrec _ "both" = [(Both ,"")] + readsPrec _ "remove" = [(Remove ,"")] + readsPrec _ _ = [] + +data Roster = Roster { ver :: Maybe Text + , items :: Map.Map Jid Item } + + +data Item = Item { approved :: Bool + , ask :: Bool + , jid :: Jid + , name :: Maybe Text + , subscription :: Subscription + , groups :: [Text] + } deriving Show + +data QueryItem = QueryItem { qiApproved :: Maybe Bool + , qiAsk :: Bool + , qiJid :: Jid + , qiName :: Maybe Text + , qiSubscription :: Maybe Subscription + , qiGroups :: [Text] + } deriving Show + +data Query = Query { queryVer :: Maybe Text + , queryItems :: [QueryItem] + } deriving Show + + +withRoster :: Maybe Roster + -> SessionConfiguration + -> (SessionConfiguration -> IO (Either XmppFailure Session)) + -> IO (Either XmppFailure (TVar Roster, Session)) +withRoster oldRoster conf startSession = do + rosterRef <- newTVarIO $ Roster Nothing Map.empty + mbSess <- startSession conf{extraStanzaHandlers = handleRoster rosterRef : + extraStanzaHandlers conf} + case mbSess of + Left e -> return $ Left e + Right sess -> do + mbRoster <- getRoster oldRoster sess + case mbRoster of + Nothing -> errorM "Pontarius.Xmpp" "Server did not return a roster" + Just roster -> atomically $ writeTVar rosterRef roster + return $ Right (rosterRef, sess) + +handleRoster :: TVar Roster -> TChan Stanza -> Stanza -> IO Bool +handleRoster rosterRef outC sta = do + case sta of + IQRequestS (iqr@IQRequest{iqRequestPayload = + iqb@Element{elementName = en}}) + | nameNamespace en == Just "jabber:iq:roster" -> do + case iqRequestFrom iqr of + Just _from -> return True -- Don't handle roster pushes from + -- unauthorized sources + Nothing -> case unpickleElem xpQuery iqb of + Right Query{ queryVer = v + , queryItems = [update] + } -> do + handleUpdate v update + atomically . writeTChan outC $ result iqr + return False + _ -> do + errorM "Pontarius.Xmpp" "Invalid roster query" + atomically . writeTChan outC $ badRequest iqr + return False + _ -> return True + where + handleUpdate v' update = atomically $ modifyTVar rosterRef $ \(Roster v is) -> + Roster (v' `mplus` v) $ case qiSubscription update of + Just Remove -> Map.delete (qiJid update) is + _ -> Map.insert (qiJid update) (toItem update) is + + badRequest (IQRequest iqid from _to lang _tp bd) = + IQErrorS $ IQError iqid Nothing from lang errBR (Just bd) + errBR = StanzaError Cancel BadRequest Nothing Nothing + result (IQRequest iqid from _to lang _tp _bd) = + IQResultS $ IQResult iqid Nothing from lang Nothing + +getRoster :: Maybe Roster -> Session -> IO (Maybe Roster) +getRoster oldRoster sess = do + res <- sendIQ' Nothing Get Nothing + (pickleElem xpQuery (Query (ver =<< oldRoster) [])) + sess + case res of + IQResponseResult (IQResult{iqResultPayload = Just ros}) + -> case unpickleElem xpQuery ros of + Left _e -> do + errorM "Pontarius.Xmpp.Roster" "getRoster: invalid query element" + return Nothing + Right roster -> return . Just $ toRoster roster + IQResponseResult (IQResult{iqResultPayload = Nothing}) -> do + return $ oldRoster + -- sever indicated that no roster updates are necessary + IQResponseTimeout -> do + errorM "Pontarius.Xmpp.Roster" "getRoster: request timed out" + return Nothing + IQResponseError e -> do + errorM "Pontarius.Xmpp.Roster" $ "getRoster: server returned error" + ++ show e + return Nothing + where + toRoster (Query v is) = Roster v (Map.fromList + $ map (\i -> (qiJid i, toItem i)) + is) + +toItem :: QueryItem -> Item +toItem qi = Item { approved = maybe False id (qiApproved qi) + , ask = qiAsk qi + , jid = qiJid qi + , name = qiName qi + , subscription = maybe None id (qiSubscription qi) + , groups = qiGroups qi + } + +xpItems :: PU [Node] [QueryItem] +xpItems = xpWrap (map (\((app_, ask_, jid_, name_, sub_), groups_) -> + QueryItem app_ ask_ jid_ name_ sub_ groups_)) + (map (\(QueryItem app_ ask_ jid_ name_ sub_ groups_) -> + ((app_, ask_, jid_, name_, sub_), groups_))) $ + xpElems "{jabber:iq:roster}item" + (xp5Tuple + (xpAttribute' "approved" xpBool) + (xpWrap (maybe False (const True)) + (\p -> if p then Just () else Nothing) $ + xpOption $ xpAttribute_ "ask" "subscribe") + (xpAttribute "jid" xpPrim) + (xpAttribute' "name" xpText) + (xpAttribute' "subscription" xpPrim) + ) + (xpFindMatches $ xpElemText "{jabber:iq:roster}group") + +xpQuery :: PU [Node] Query +xpQuery = xpWrap (\(ver_, items_) -> Query ver_ items_ ) + (\(Query ver_ items_) -> (ver_, items_)) $ + xpElem "{jabber:iq:roster}query" + (xpAttribute' "ver" xpText) + xpItems