From 276988ceb5fcd1204af8f17bc560d88d4664f39b Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Fri, 22 Nov 2013 21:36:01 +0100 Subject: [PATCH] implement DISCO handlers --- source/Network/Xmpp/Stanza.hs | 15 +- source/Network/Xmpp/Xep/ServiceDiscovery.hs | 193 ++++++++++++-------- 2 files changed, 134 insertions(+), 74 deletions(-) diff --git a/source/Network/Xmpp/Stanza.hs b/source/Network/Xmpp/Stanza.hs index 232bc83..802be5a 100644 --- a/source/Network/Xmpp/Stanza.hs +++ b/source/Network/Xmpp/Stanza.hs @@ -9,6 +9,7 @@ module Network.Xmpp.Stanza where import Data.XML.Types import Network.Xmpp.Types +import Network.Xmpp.Lens -- | Request subscription with an entity. presenceSubscribe :: Jid -> Presence @@ -58,12 +59,22 @@ presTo pres to = pres{presenceTo = Just to} -- | Create an IQ error response to an IQ request using the given condition. The -- error type is derived from the condition using 'associatedErrorType' and -- both text and the application specific condition are left empty -iqErrorResponse :: StanzaErrorCondition -> IQRequest -> IQError -iqErrorResponse condition (IQRequest iqid from _to lang _tp bd) = +iqError :: StanzaErrorCondition -> IQRequest -> IQError +iqError condition (IQRequest iqid from _to lang _tp _bd) = IQError iqid Nothing from lang err Nothing where err = StanzaError (associatedErrorType condition) condition Nothing Nothing +-- | Create an IQ Result matching an IQ request +iqResult :: Maybe Element -> IQRequest -> IQResult +iqResult pl iqr = IQResult + { iqResultID = iqRequestID iqr + , iqResultFrom = Nothing + , iqResultTo = view from iqr + , iqResultLangTag = view lang iqr + , iqResultPayload = pl + } + -- | The RECOMMENDED error type associated with an error condition. The -- following conditions allow for multiple types -- diff --git a/source/Network/Xmpp/Xep/ServiceDiscovery.hs b/source/Network/Xmpp/Xep/ServiceDiscovery.hs index aa39057..b953f44 100644 --- a/source/Network/Xmpp/Xep/ServiceDiscovery.hs +++ b/source/Network/Xmpp/Xep/ServiceDiscovery.hs @@ -9,24 +9,25 @@ module Network.Xmpp.Xep.ServiceDiscovery ( QueryInfoResult(..) , Identity(..) , queryInfo - , xmppQueryInfo , Item , queryItems , DiscoError(..) ) where -import Control.Monad.IO.Class +import Control.Applicative ((<$>)) import Control.Monad.Error - +import qualified Data.Map as Map import qualified Data.Text as Text import Data.XML.Pickle import Data.XML.Types - import Network.Xmpp -import Network.Xmpp.Internal +import Network.Xmpp.Types +import Network.Xmpp.Concurrent.Types +import Network.Xmpp.Lens import Network.Xmpp.Marshal -import Control.Concurrent.STM.TMVar +import Network.Xmpp.Plugins +import Network.Xmpp.Stanza data DiscoError = DiscoNoQueryElement | DiscoIQError (Maybe IQError) @@ -37,23 +38,120 @@ data DiscoError = DiscoNoQueryElement instance Error DiscoError +-- Identity +--------------------- + data Identity = Ident { iCategory :: Text.Text , iName :: Maybe Text.Text , iType :: Text.Text , iLang :: Maybe LangTag } deriving Show + + data QueryInfoResult = QIR { qiNode :: Maybe Text.Text , qiIdentities :: [Identity] , qiFeatures :: [Text.Text] } deriving Show + +-- | Query an entity for its identity and features +queryInfo :: Maybe Integer -- ^ timeout + -> Jid -- ^ Entity to query + -> Maybe Text.Text -- ^ Node + -> Session + -> IO (Either DiscoError QueryInfoResult) +queryInfo timeout to node context = do + res <- sendIQ' timeout (Just to) Get Nothing queryBody context + return $ case fst <$> res of + Left e -> Left $ DiscoIQError Nothing + Right (IQResponseError e) -> Left $ DiscoIQError (Just e) + Right (IQResponseResult r) -> case iqResultPayload r of + Nothing -> Left DiscoNoQueryElement + Just p -> case unpickleElem xpQueryInfo p of + Left e -> Left $ DiscoXmlError p e + Right r -> Right r + where + queryBody = pickleElem xpQueryInfo (QIR node [] []) + + +handleInfoRequest + :: [Identity] + -> [Text.Text] + -> Map.Map Text.Text ([Identity], [Text.Text]) + -> (Stanza -> IO Bool) + -> Stanza + -> [Annotation] + -> IO [Annotated Stanza] +handleInfoRequest ids fs infoNodes = + handleIQRequest Get pickler $ \iqr (QIR node _ _) _ -> + return . fmap (\x -> (Just $ pickle (xpRoot $ pickler) x, [])) $ + case node of + Nothing -> Right . QIR node ids $ addDisco fs + Just n -> case Map.lookup n infoNodes of + Nothing -> Left $ iqError ItemNotFound iqr + Just (ids', fs') -> Right . QIR node ids' $ addDisco fs' + where pickler = xpUnliftElems xpQueryInfo + addDisco x = "http://jabber.org/protocol/disco#info" + : "http://jabber.org/protocol/disco#items" + : x + + +-- Items +-------------------------- + +data Item = Item { itemJid :: Jid + , itemName :: Maybe Text.Text + , itemNode :: Maybe Text.Text + } deriving Show + +-- | Query an entity for Items of a node +queryItems :: Maybe Integer -- ^ Timeout + -> Jid -- ^ Entity to query + -> Maybe Text.Text -- ^ Node + -> Session + -> IO (Either DiscoError (Maybe Text.Text, [Item])) +queryItems timeout to node session = do + res <- sendIQ' timeout (Just to) Get Nothing queryBody session + return $ case fst <$> res of + Left _ -> Left $ DiscoIQError Nothing + Right (IQResponseError e) -> Left $ DiscoIQError (Just e) + Right (IQResponseResult r) -> case iqResultPayload r of + Nothing -> Left DiscoNoQueryElement + Just p -> case unpickleElem xpQueryItems p of + Left e -> Left $ DiscoXmlError p e + Right r -> Right r + where + queryBody = pickleElem xpQueryItems (node, []) + + +handleItemsRequest :: (Maybe Text.Text -> IO (Maybe [Item])) + -> (Stanza -> IO Bool) + -> Stanza + -> [Annotation] + -> IO [Annotated Stanza] +handleItemsRequest getItems = handleIQRequest Get pickler $ \iqr (node, _) _ -> do + is <- getItems node + case is of + Nothing -> return . Left $ iqError ItemNotFound iqr + Just is -> return $ Right ( Just $ pickle (xpRoot pickler) (node, is) + , [] + ) + + where + pickler = xpUnliftElems xpQueryItems + +----------------------- +-- Picklers ----------- +----------------------- + discoInfoNS :: Text.Text discoInfoNS = "http://jabber.org/protocol/disco#info" infoN :: Text.Text -> Name infoN name = Name name (Just discoInfoNS) Nothing +xpIdentities :: PU [Node] [Identity] xpIdentities = xpWrap (map $(\(cat, n, tp, lang) -> Ident cat n tp lang) . fst) (map $ \(Ident cat n tp lang) -> ((cat, n, tp, lang),())) $ xpElems (infoN "identity") @@ -71,6 +169,7 @@ xpFeatures = xpWrap (map fst) (map (,())) $ (xpAttr "var" xpText) xpUnit +xpQueryInfo :: PU [Node] QueryInfoResult xpQueryInfo = xpWrap (\(nd, (feats, ids)) -> QIR nd ids feats) (\(QIR nd ids feats) -> (nd, (feats, ids))) $ xpElem (infoN "query") @@ -80,60 +179,13 @@ xpQueryInfo = xpWrap (\(nd, (feats, ids)) -> QIR nd ids feats) xpIdentities ) --- | Query an entity for its identity and features -queryInfo :: Jid -- ^ Entity to query - -> Maybe Text.Text -- ^ Node - -> Session - -> IO (Either DiscoError QueryInfoResult) -queryInfo to node context = do - res <- sendIQ' (Just to) Get Nothing queryBody context - return $ case res of - Nothing -> Left $ DiscoIQError Nothing - Just (IQResponseError e) -> Left $ DiscoIQError (Just e) - Just IQResponseTimeout -> Left $ DiscoTimeout - Just (IQResponseResult r) -> case iqResultPayload r of - Nothing -> Left DiscoNoQueryElement - Just p -> case unpickleElem xpQueryInfo p of - Left e -> Left $ DiscoXmlError p e - Right r -> Right r - where - queryBody = pickleElem xpQueryInfo (QIR node [] []) - - -xmppQueryInfo :: Maybe Jid - -> Maybe Text.Text - -> Stream - -> IO (Either DiscoError QueryInfoResult) -xmppQueryInfo to node con = do - res <- pushIQ "info" to Get Nothing queryBody con - return $ case res of - Left e -> Left $ DiscoIQError Nothing - Right res' -> case res' of - Left e -> Left $ DiscoIQError (Just e) - Right r -> case iqResultPayload r of - Nothing -> Left DiscoNoQueryElement - Just p -> case unpickleElem xpQueryInfo p of - Left e -> Left $ DiscoXmlError p e - Right r -> Right r - where - queryBody = pickleElem xpQueryInfo (QIR node [] []) - - --- --- Items --- - -data Item = Item { itemJid :: Jid - , itemName :: Maybe Text.Text - , itemNode :: Maybe Text.Text - } deriving Show - discoItemsNS :: Text.Text discoItemsNS = "http://jabber.org/protocol/disco#items" itemsN :: Text.Text -> Name itemsN n = Name n (Just discoItemsNS) Nothing +xpItem :: PU [Node] Item xpItem = xpWrap (\(jid, name, node) -> Item jid name node) (\(Item jid name node) -> (jid, name, node)) $ xpElemAttrs (itemsN "item") @@ -143,25 +195,22 @@ xpItem = xpWrap (\(jid, name, node) -> Item jid name node) (xpAttrImplied "node" xpText)) +xpQueryItems :: PU [Node] (Maybe Text.Text, [Item]) xpQueryItems = xpElem (itemsN "query") (xpAttrImplied "node" xpText) (xpAll xpItem) --- | Query an entity for Items of a node -queryItems :: Jid -- ^ Entity to query - -> Maybe Text.Text -- ^ Node - -> Session - -> IO (Either DiscoError (Maybe Text.Text, [Item])) -queryItems to node session = do - res <- sendIQ' (Just to) Get Nothing queryBody session - return $ case res of - Nothing -> Left $ DiscoIQError Nothing - Just (IQResponseError e) -> Left $ DiscoIQError (Just e) - Just IQResponseTimeout -> Left $ DiscoTimeout - Just (IQResponseResult r) -> case iqResultPayload r of - Nothing -> Left DiscoNoQueryElement - Just p -> case unpickleElem xpQueryItems p of - Left e -> Left $ DiscoXmlError p e - Right r -> Right r - where - queryBody = pickleElem xpQueryItems (node, []) + +disco :: [Identity] + -> [Text.Text] + -> Map.Map Text.Text ([Identity], [Text.Text]) + -> (Maybe Text.Text -> IO (Maybe [Item])) + -> Plugin +disco ids fs ins items out = return $ Plugin' + { inHandler = \sta as -> do + res <- handleInfoRequest ids fs ins out sta as + concat <$> + forM res (uncurry $ handleItemsRequest items out) + , outHandler = out + , onSessionUp = const $ return () + }