From 7a5699ee9b7fb7107ee487d1f642aace914273ae Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 19 Mar 2013 19:28:13 +0100 Subject: [PATCH 1/3] Add support for reader plugins --- source/Network/Xmpp/Concurrent.hs | 64 +++++++++++++++++++------------ source/Network/Xmpp/Types.hs | 7 ++++ 2 files changed, 46 insertions(+), 25 deletions(-) diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 4344875..c40090f 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/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,44 +21,56 @@ 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 -import Data.Default -import System.Log.Logger -import Control.Monad.State.Strict +import Data.Default +import System.Log.Logger +import Control.Monad.State.Strict + +runHandlers :: (TChan Stanza) -> [StanzaHandler] -> Stanza -> IO () +runHandlers _ [] _ = return () +runHandlers outC (h:hands) sta = do + res <- h outC sta + case res of + True -> runHandlers outC hands sta + False -> return () + +toChan :: TChan Stanza -> StanzaHandler +toChan stanzaC _ sta = do + atomically $ writeTChan stanzaC sta + return True + -toChans :: TChan Stanza - -> TChan Stanza - -> TVar IQHandlers - -> Stanza - -> IO () -toChans stanzaC outC iqHands sta = atomically $ do - writeTChan stanzaC sta +handleIQ :: TVar IQHandlers + -> StanzaHandler +handleIQ iqHands outC sta = atomically $ do case sta of - IQRequestS i -> handleIQRequest iqHands i - IQResultS i -> handleIQResponse iqHands (Right i) - IQErrorS i -> handleIQResponse iqHands (Left i) - _ -> return () + IQRequestS i -> handleIQRequest iqHands i >> return False + IQResultS i -> handleIQResponse iqHands (Right i) >> return False + IQErrorS i -> handleIQResponse iqHands (Left i) >> return False + _ -> 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 diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 92d9a40..de22e26 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -36,6 +36,7 @@ module Network.Xmpp.Types , StreamState(..) , ConnectionState(..) , StreamErrorInfo(..) + , StanzaHandler , StreamConfiguration(..) , langTag , Jid(..) @@ -1105,6 +1106,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 +1118,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 +1130,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. From 3d0c5cc72b0f6b6591e2a0286badb32204d415e3 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 19 Mar 2013 19:28:40 +0100 Subject: [PATCH 2/3] 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 From 652384c4b0124f355709b7194575f52fd027a1f2 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 19 Mar 2013 19:28:58 +0100 Subject: [PATCH 3/3] Make Network.Xmpp.Types warning-clean --- source/Network/Xmpp/Types.hs | 41 +++++++++++------------------------- 1 file changed, 12 insertions(+), 29 deletions(-) diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index de22e26..c1e9857 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -53,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.Maybe (fromJust, fromMaybe, maybeToList) -import Data.String(IsString(..)) +import Data.Default +import Data.Maybe (fromJust, maybeToList) +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. @@ -777,8 +761,7 @@ langTagParser = do subtag :: AP.Parser Text.Text subtag = do AP.skip (== '-') - subtag <- tag - return subtag + tag tagChars :: [Char] tagChars = ['a'..'z'] ++ ['A'..'Z'] @@ -875,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) = @@ -958,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