Merge branch 'master' of git://github.com/Philonous/pontarius

source/Network/Xmpp/Concurrent.hs

@@ -8,14 +8,12 @@ module Network.Xmpp.Concurrent
   , module Network.Xmpp.Concurrent.Message
   , module Network.Xmpp.Concurrent.Presence
   , module Network.Xmpp.Concurrent.IQ
-  , toChans
+  , StanzaHandler
   , newSession
   , writeWorker
   , session
   ) where
 
-import           Network.Xmpp.Concurrent.Monad
-import           Network.Xmpp.Concurrent.Threads
 import           Control.Applicative((<$>),(<*>))
 import           Control.Concurrent
 import           Control.Concurrent.STM
@@ -23,25 +21,27 @@ import           Control.Monad
 import qualified Data.ByteString as BS
 import           Data.IORef
 import qualified Data.Map as Map
+import           Data.Maybe
 import           Data.Maybe (fromMaybe)
+import           Data.Text as Text
 import           Data.XML.Types
+import           Network
+import qualified Network.TLS as TLS
 import           Network.Xmpp.Concurrent.Basic
 import           Network.Xmpp.Concurrent.IQ
 import           Network.Xmpp.Concurrent.Message
+import           Network.Xmpp.Concurrent.Monad
 import           Network.Xmpp.Concurrent.Presence
-import           Network.Xmpp.Concurrent.Types
 import           Network.Xmpp.Concurrent.Threads
+import           Network.Xmpp.Concurrent.Threads
+import           Network.Xmpp.Concurrent.Types
 import           Network.Xmpp.Marshal
-import           Network.Xmpp.Types
-import           Network
-import           Data.Text as Text
-import           Network.Xmpp.Tls
-import qualified Network.TLS as TLS
 import           Network.Xmpp.Sasl
 import           Network.Xmpp.Sasl.Mechanisms
 import           Network.Xmpp.Sasl.Types
-import           Data.Maybe
 import           Network.Xmpp.Stream
+import           Network.Xmpp.Tls
+import           Network.Xmpp.Types
 import           Network.Xmpp.Utilities
 
 import           Control.Monad.Error
@@ -49,18 +49,28 @@ import Data.Default
 import           System.Log.Logger
 import           Control.Monad.State.Strict
 
-toChans :: TChan Stanza
+runHandlers :: (TChan Stanza) -> [StanzaHandler] -> Stanza -> IO ()
-        -> TChan Stanza
+runHandlers _    []        _   = return ()
-        -> TVar IQHandlers
+runHandlers outC (h:hands) sta = do
-        -> Stanza
+    res <- h outC sta
-        -> IO ()
+    case res of
-toChans stanzaC outC iqHands sta = atomically $ do
+        True -> runHandlers outC hands sta
-        writeTChan stanzaC sta
+        False -> return ()
+
+toChan :: TChan Stanza -> StanzaHandler
+toChan stanzaC _ sta = do
+    atomically $ writeTChan stanzaC sta
+    return True
+
+
+handleIQ :: TVar IQHandlers
+         -> StanzaHandler
+handleIQ iqHands outC sta = atomically $ do
         case sta of
-            IQRequestS     i -> handleIQRequest iqHands i
+            IQRequestS     i -> handleIQRequest iqHands i >> return False
-            IQResultS      i -> handleIQResponse iqHands (Right i)
+            IQResultS      i -> handleIQResponse iqHands (Right i) >> return False
-            IQErrorS       i -> handleIQResponse iqHands (Left i)
+            IQErrorS       i -> handleIQResponse iqHands (Left i) >> return False
-            _                -> return ()
+            _                -> return True
   where
     -- If the IQ request has a namespace, send it through the appropriate channel.
     handleIQRequest :: TVar IQHandlers -> IQRequest -> STM ()
@@ -96,7 +106,11 @@ newSession stream config = runErrorT $ do
     stanzaChan <- lift newTChanIO
     iqHandlers <- lift $ newTVarIO (Map.empty, Map.empty)
     eh <- lift $ newTVarIO $ EventHandlers { connectionClosedHandler = sessionClosedHandler config }
-    let stanzaHandler = toChans stanzaChan outC iqHandlers
+    let stanzaHandler = runHandlers outC $ Prelude.concat [ [toChan stanzaChan]
+                                                          , extraStanzaHandlers
+                                                                config
+                                                          , [handleIQ iqHandlers]
+                                                          ]
     (kill, wLock, streamState, readerThread) <- ErrorT $ startThreadsWith stanzaHandler eh stream
     writer <- lift $ forkIO $ writeWorker outC wLock
     return $ Session { stanzaCh = stanzaChan

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

source/Network/Xmpp/Types.hs

@@ -36,6 +36,7 @@ module Network.Xmpp.Types
     , StreamState(..)
     , ConnectionState(..)
     , StreamErrorInfo(..)
+    , StanzaHandler
     , StreamConfiguration(..)
     , langTag
     , Jid(..)
@@ -52,45 +53,29 @@ module Network.Xmpp.Types
     )
        where
 
+import           Control.Applicative ((<$>), (<|>), many)
 import           Control.Concurrent.STM
 import           Control.Exception
 import           Control.Monad.Error
-import           Control.Monad.IO.Class
-import           Control.Monad.State.Strict
-
 import qualified Data.Attoparsec.Text as AP
 import qualified Data.ByteString as BS
 import           Data.Conduit
-import           Data.IORef
+import           Data.Default
-import           Data.Maybe (fromJust, fromMaybe, maybeToList)
+import           Data.Maybe (fromJust, maybeToList)
-import           Data.String(IsString(..))
+import qualified Data.Set as Set
+import           Data.String (IsString(..))
 import           Data.Text (Text)
 import qualified Data.Text as Text
 import           Data.Typeable(Typeable)
 import           Data.XML.Types
-
+import           Network
+import           Network.DNS
+import           Network.Socket
 import           Network.TLS hiding (Version)
 import           Network.TLS.Extra
-
-import qualified Network as N
-
-import           System.IO
-
-import           Control.Applicative ((<$>), (<|>), many)
-import           Control.Monad(guard)
-
-import qualified Data.Set as Set
-import           Data.String (IsString(..))
 import qualified Text.NamePrep as SP
 import qualified Text.StringPrep as SP
 
-import           Network
-import           Network.DNS
-import           Network.Socket
-
-import Data.Default
-import Data.IP
-
 -- |
 -- Wraps a string of random characters that, when using an appropriate
 -- @IdGenerator@, is guaranteed to be unique for the Xmpp session.
@@ -776,8 +761,7 @@ langTagParser = do
     subtag :: AP.Parser Text.Text
     subtag = do
         AP.skip (== '-')
-        subtag <- tag
+        tag
-        return subtag
     tagChars :: [Char]
     tagChars = ['a'..'z'] ++ ['A'..'Z']
 
@@ -874,7 +858,7 @@ data Jid = Jid { -- | The @localpart@ of a JID is an optional identifier placed
                  -- the entity associated with an XMPP localpart at a domain
                  -- (i.e., @localpart\@domainpart/resourcepart@).
                , resourcepart :: !(Maybe Text)
-               } deriving Eq
+               } deriving (Eq, Ord)
 
 instance Show Jid where
   show (Jid nd dmn res) =
@@ -957,9 +941,9 @@ jidParts = do
           -- Case 2: We found a '/'; the JID is in the form
           -- domainpart/resourcepart.
           <|> do
-              b <- resourcePartP
+              b' <- resourcePartP
               AP.endOfInput
-              return (Nothing, a, Just b)
+              return (Nothing, a, Just b')
           -- Case 3: We have reached EOF; we have an JID consisting of only a
           -- domainpart.
         <|> do
@@ -1105,6 +1089,10 @@ hostnameP = do
                     then fail "Hostname too long."
                     else return $ Text.concat [label, Text.pack ".", r]
 
+type StanzaHandler =  TChan Stanza -- ^ outgoing stanza
+                   -> Stanza       -- ^ stanza to handle
+                   -> IO Bool      -- ^ True when processing should continue
+
 -- | Configuration for the @Session@ object.
 data SessionConfiguration = SessionConfiguration
     { -- | Configuration for the @Stream@ object.
@@ -1113,6 +1101,7 @@ data SessionConfiguration = SessionConfiguration
     , sessionClosedHandler :: XmppFailure -> IO ()
       -- | Function to generate the stream of stanza identifiers.
     , sessionStanzaIDs :: IO StanzaID
+    , extraStanzaHandlers   :: [StanzaHandler]
     }
 
 instance Default SessionConfiguration where
@@ -1124,6 +1113,7 @@ instance Default SessionConfiguration where
                                          curId <- readTVar idRef
                                          writeTVar idRef (curId + 1 :: Integer)
                                          return . read. show $ curId
+                               , extraStanzaHandlers = []
                                }
 
 -- | How the client should behave in regards to TLS.