integrate roster management

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

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 }
+    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

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
     }
 

source/Network/Xmpp/IM.hs

@@ -9,7 +9,13 @@ module Network.Xmpp.IM
   , answerIM
     -- * 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

source/Network/Xmpp/IM/Roster.hs

@@ -1,83 +1,39 @@
+{-# OPTIONS_HADDOCK hide #-}
 {-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module Network.Xmpp.IM.Roster
+module Network.Xmpp.IM.Roster where
-where
 
 import           Control.Concurrent.STM
 import           Control.Monad
-import Data.Text (Text)
+import qualified Data.Map.Strict as Map
+import           Data.Maybe (isJust)
 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.IM.Roster.Types
+import           Network.Xmpp.Marshal
+import           Network.Xmpp.Concurrent.Types
 import           Network.Xmpp.Types
+import           Network.Xmpp.Concurrent.IQ
 
-data Subscription = None | To | From | Both | Remove deriving Eq
+getRoster :: Session -> IO Roster
-
+getRoster session = atomically $ readTVar (rosterRef session)
-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
+initRoster :: Session -> IO ()
-           -> SessionConfiguration
+initRoster session = do
-           -> (SessionConfiguration -> IO (Either XmppFailure Session))
+    oldRoster <- getRoster session
-           -> IO (Either XmppFailure (TVar Roster, Session))
+    mbRoster <- retrieveRoster (if isJust (ver oldRoster) then Just oldRoster
-withRoster oldRoster conf startSession = do
+                                                          else Nothing ) session
-    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"
+        Nothing -> errorM "Pontarius.Xmpp"
-                Just roster -> atomically $ writeTVar rosterRef roster
+                          "Server did not return a roster"
-            return $ Right (rosterRef, sess)
+        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)
+retrieveRoster :: Maybe Roster -> Session -> IO (Maybe Roster)
-getRoster oldRoster sess = do
+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

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

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.