From d8ae2d074eee80c6fa83c53f946a3faccf28f273 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Fri, 22 Mar 2013 13:15:49 +0100 Subject: [PATCH] integrate roster management --- pontarius-xmpp.cabal | 2 + source/Network/Xmpp/Concurrent.hs | 17 +++- source/Network/Xmpp/Concurrent/Types.hs | 3 + source/Network/Xmpp/IM.hs | 8 +- source/Network/Xmpp/IM/Roster.hs | 108 +++++++----------------- source/Network/Xmpp/IM/Roster/Types.hs | 47 +++++++++++ source/Network/Xmpp/Types.hs | 1 + 7 files changed, 105 insertions(+), 81 deletions(-) create mode 100644 source/Network/Xmpp/IM/Roster/Types.hs diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 0c830c4..a1d8ab3 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -82,6 +82,8 @@ Library , Network.Xmpp.Tls , Network.Xmpp.Types , Network.Xmpp.Utilities + , Network.Xmpp.IM.Roster + , Network.Xmpp.IM.Roster.Types GHC-Options: -Wall Source-Repository head diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 772ca34..eaa5943 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -32,6 +32,8 @@ import Network.Xmpp.Concurrent.Monad import Network.Xmpp.Concurrent.Presence import Network.Xmpp.Concurrent.Threads import Network.Xmpp.Concurrent.Types +import Network.Xmpp.IM.Roster.Types +import Network.Xmpp.IM.Roster import Network.Xmpp.Marshal import Network.Xmpp.Sasl import Network.Xmpp.Sasl.Types @@ -98,10 +100,15 @@ newSession stream config = runErrorT $ do stanzaChan <- lift newTChanIO iqHands <- lift $ newTVarIO (Map.empty, Map.empty) eh <- lift $ newTVarIO $ EventHandlers { connectionClosedHandler = sessionClosedHandler config } - let stanzaHandler = runHandlers outC $ Prelude.concat [ [toChan stanzaChan] + ros <- liftIO . newTVarIO $ Roster Nothing Map.empty + let rosterH = if (enableRoster config) then handleRoster ros + else \ _ _ -> return True + let stanzaHandler = runHandlers outC $ Prelude.concat [ [ toChan stanzaChan ] , extraStanzaHandlers config - , [handleIQ iqHands] + , [ handleIQ iqHands + , rosterH + ] ] (kill, wLock, streamState, reader) <- ErrorT $ startThreadsWith stanzaHandler eh stream writer <- lift $ forkIO $ writeWorker outC wLock @@ -116,6 +123,7 @@ newSession stream config = runErrorT $ do , eventHandlers = eh , stopThreads = kill >> killThread writer , conf = config + , rosterRef = ros } -- Worker to write stanzas to the stream concurrently. @@ -137,12 +145,12 @@ writeWorker stCh writeR = forever $ do -- third parameter is a 'Just' value, @session@ will attempt to authenticate and -- acquire an XMPP resource. session :: HostName -- ^ The hostname / realm - -> SessionConfiguration -- ^ configuration details -> Maybe ([SaslHandler], Maybe Text) -- ^ SASL handlers and the desired -- JID resource (or Nothing to let -- the server decide) + -> SessionConfiguration -- ^ configuration details -> IO (Either XmppFailure Session) -session realm config mbSasl = runErrorT $ do +session realm mbSasl config = runErrorT $ do stream <- ErrorT $ openStream realm (sessionStreamConfiguration config) ErrorT $ tls stream mbAuthError <- case mbSasl of @@ -152,4 +160,5 @@ session realm config mbSasl = runErrorT $ do Nothing -> return () Just _ -> throwError XmppAuthFailure ses <- ErrorT $ newSession stream config + liftIO $ when (enableRoster config) $ initRoster ses return ses diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index 4a4b2e5..c98e45c 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -10,6 +10,8 @@ import qualified Data.ByteString as BS import qualified Data.Map as Map import Data.Text (Text) import Data.Typeable + +import Network.Xmpp.IM.Roster.Types import Network.Xmpp.Types -- | Handlers to be run when the Xmpp session ends and when the Xmpp connection is @@ -41,6 +43,7 @@ data Session = Session , streamRef :: TMVar (Stream) , eventHandlers :: TVar EventHandlers , stopThreads :: IO () + , rosterRef :: TVar Roster , conf :: SessionConfiguration } diff --git a/source/Network/Xmpp/IM.hs b/source/Network/Xmpp/IM.hs index 35b2c9c..d8793a0 100644 --- a/source/Network/Xmpp/IM.hs +++ b/source/Network/Xmpp/IM.hs @@ -7,9 +7,15 @@ module Network.Xmpp.IM , newIM , simpleIM , answerIM - -- * Presence + -- * Presence , module Network.Xmpp.IM.Presence + -- * Roster + , Roster(..) + , Item(..) + , getRoster ) where import Network.Xmpp.IM.Message import Network.Xmpp.IM.Presence +import Network.Xmpp.IM.Roster +import Network.Xmpp.IM.Roster.Types diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs index 1f359f9..cd7a0ca 100644 --- a/source/Network/Xmpp/IM/Roster.hs +++ b/source/Network/Xmpp/IM/Roster.hs @@ -1,83 +1,39 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} -module Network.Xmpp.IM.Roster -where +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 Control.Concurrent.STM +import Control.Monad 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) +import Data.Maybe (isJust) +import Data.XML.Pickle +import Data.XML.Types +import System.Log.Logger + +import Network.Xmpp.IM.Roster.Types +import Network.Xmpp.Marshal +import Network.Xmpp.Concurrent.Types +import Network.Xmpp.Types +import Network.Xmpp.Concurrent.IQ + +getRoster :: Session -> IO Roster +getRoster session = atomically $ readTVar (rosterRef session) + +initRoster :: Session -> IO () +initRoster session = do + oldRoster <- getRoster session + mbRoster <- retrieveRoster (if isJust (ver oldRoster) then Just oldRoster + else Nothing ) session + case mbRoster of + Nothing -> errorM "Pontarius.Xmpp" + "Server did not return a roster" + Just roster -> atomically $ writeTVar (rosterRef session) roster handleRoster :: TVar Roster -> TChan Stanza -> Stanza -> IO Bool -handleRoster rosterRef outC sta = do +handleRoster ref outC sta = do case sta of IQRequestS (iqr@IQRequest{iqRequestPayload = iqb@Element{elementName = en}}) @@ -98,7 +54,7 @@ handleRoster rosterRef outC sta = do return False _ -> return True where - handleUpdate v' update = atomically $ modifyTVar rosterRef $ \(Roster v is) -> + handleUpdate v' update = atomically $ modifyTVar ref $ \(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 @@ -109,8 +65,8 @@ handleRoster rosterRef outC sta = do 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 +retrieveRoster :: Maybe Roster -> Session -> IO (Maybe Roster) +retrieveRoster oldRoster sess = do res <- sendIQ' Nothing Get Nothing (pickleElem xpQuery (Query (ver =<< oldRoster) [])) sess @@ -120,7 +76,7 @@ getRoster oldRoster sess = do Left _e -> do errorM "Pontarius.Xmpp.Roster" "getRoster: invalid query element" return Nothing - Right roster -> return . Just $ toRoster roster + Right ros' -> return . Just $ toRoster ros' IQResponseResult (IQResult{iqResultPayload = Nothing}) -> do return $ oldRoster -- sever indicated that no roster updates are necessary diff --git a/source/Network/Xmpp/IM/Roster/Types.hs b/source/Network/Xmpp/IM/Roster/Types.hs new file mode 100644 index 0000000..04854b4 --- /dev/null +++ b/source/Network/Xmpp/IM/Roster/Types.hs @@ -0,0 +1,47 @@ +module Network.Xmpp.IM.Roster.Types where + +import qualified Data.Map as Map +import Data.Text (Text) +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 } deriving Show + + + +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 diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index bab4d33..8f4e9e1 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -1106,6 +1106,7 @@ instance Default SessionConfiguration where writeTVar idRef (curId + 1 :: Integer) return . StanzaID . Text.pack . show $ curId , extraStanzaHandlers = [] + , enableRoster = True } -- | How the client should behave in regards to TLS.