From 9b748870dc73b9612f7213add66252d5602b3a44 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 3 Jul 2012 13:11:45 +0200 Subject: [PATCH 1/3] update to xml-picklers 0.2 --- pontarius-xmpp.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index acb5bbb..78a5ced 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -49,7 +49,7 @@ Library , stm -any , xml-types -any , xml-conduit >= 1.0 - , xml-picklers >= 0.1 + , xml-picklers >= 0.2 , data-default -any , stringprep >= 0.1.5 Exposed-modules: Network.Xmpp From bcbe68bcac76060ae6482bd85242a93a3dc3e5a0 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 5 Jul 2012 14:18:23 +0200 Subject: [PATCH 2/3] Update to xml-picklers 0.2.2 Add LangTag to Network.Xmpp re-export list --- pontarius-xmpp.cabal | 2 +- source/Network/Xmpp.hs | 1 + source/Network/Xmpp/IM/Message.hs | 6 +++--- source/Network/Xmpp/Monad.hs | 2 +- source/Network/Xmpp/Pickle.hs | 4 ++-- source/Network/Xmpp/Stream.hs | 2 +- 6 files changed, 9 insertions(+), 8 deletions(-) diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 78a5ced..0238254 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -49,7 +49,7 @@ Library , stm -any , xml-types -any , xml-conduit >= 1.0 - , xml-picklers >= 0.2 + , xml-picklers >= 0.2.2 , data-default -any , stringprep >= 0.1.5 Exposed-modules: Network.Xmpp diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index d3924ac..7c7ee8b 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -144,6 +144,7 @@ module Network.Xmpp , fork , forkSession -- * Misc + , LangTag(..) , exampleParams ) where diff --git a/source/Network/Xmpp/IM/Message.hs b/source/Network/Xmpp/IM/Message.hs index 45b5193..770e59c 100644 --- a/source/Network/Xmpp/IM/Message.hs +++ b/source/Network/Xmpp/IM/Message.hs @@ -19,19 +19,19 @@ data MessageThread = MessageThread data MessageSubject = MessageSubject (Maybe LangTag) Text xpMessageSubject :: PU [Element] MessageSubject -xpMessageSubject = xpElems . +xpMessageSubject = xpUnliftElems . xpWrap (\(l, s) -> MessageSubject l s) (\(MessageSubject l s) -> (l,s)) $ xpElem "{jabber:client}subject" xpLangTag $ xpContent xpId xpMessageBody :: PU [Element] MessageBody -xpMessageBody = xpElems . +xpMessageBody = xpUnliftElems . xpWrap (\(l, s) -> MessageBody l s) (\(MessageBody l s) -> (l,s)) $ xpElem "{jabber:client}body" xpLangTag $ xpContent xpId xpMessageThread :: PU [Element] MessageThread -xpMessageThread = xpElems +xpMessageThread = xpUnliftElems . xpWrap (\(t, p) -> MessageThread p t) (\(MessageThread p t) -> (t,p)) $ xpElem "{jabber:client}thread" diff --git a/source/Network/Xmpp/Monad.hs b/source/Network/Xmpp/Monad.hs index 5d01f74..97fcbe5 100644 --- a/source/Network/Xmpp/Monad.hs +++ b/source/Network/Xmpp/Monad.hs @@ -90,7 +90,7 @@ pullPickle :: PU [Node] a -> XmppConMonad a pullPickle p = do res <- unpickleElem p <$> pullElement case res of - Left e -> liftIO . Ex.throwIO $ StreamXMLError e + Left e -> liftIO . Ex.throwIO $ StreamXMLError (show e) Right r -> return r -- Pulls a stanza (or stream error) from the stream. Throws an error on a stream diff --git a/source/Network/Xmpp/Pickle.hs b/source/Network/Xmpp/Pickle.hs index 9937e72..04d5eee 100644 --- a/source/Network/Xmpp/Pickle.hs +++ b/source/Network/Xmpp/Pickle.hs @@ -70,11 +70,11 @@ right (Right r) = r unpickleElem' :: PU [Node] c -> Element -> c unpickleElem' p x = case unpickle (xpNodeElem p) x of - Left l -> error $ l ++ "\n saw: " ++ ppElement x + Left l -> error $ (show l) ++ "\n saw: " ++ ppElement x Right r -> r -- Given a pickler and an element, produces an object. -unpickleElem :: PU [Node] a -> Element -> Either String a +unpickleElem :: PU [Node] a -> Element -> Either UnpickleError a unpickleElem p x = unpickle (xpNodeElem p) x -- Given a pickler and an object, produces an Element. diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index a51114f..b91088e 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -33,7 +33,7 @@ streamUnpickleElem :: PU [Node] a -> StreamSink a streamUnpickleElem p x = do case unpickleElem p x of - Left l -> throwError $ StreamXMLError l + Left l -> throwError $ StreamXMLError (show l) Right r -> return r -- This is the conduit sink that handles the stream XML events. We extend it From 3500b7ad7c7420a7486dd85e1353607ec8908f45 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 5 Jul 2012 14:24:46 +0200 Subject: [PATCH 3/3] add Network.Xmpp.Xep.ServiceDiscovery --- pontarius-xmpp.cabal | 1 + source/Network/Xmpp/Xep/ServiceDiscovery.hs | 137 ++++++++++++++++++++ 2 files changed, 138 insertions(+) create mode 100644 source/Network/Xmpp/Xep/ServiceDiscovery.hs diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 0238254..81e168f 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -70,6 +70,7 @@ Library , Network.Xmpp.Stream , Network.Xmpp.TLS , Network.Xmpp.Types + , Network.Xmpp.Xep.ServiceDiscovery Other-modules: Network.Xmpp.Jid , Network.Xmpp.Concurrent.Types diff --git a/source/Network/Xmpp/Xep/ServiceDiscovery.hs b/source/Network/Xmpp/Xep/ServiceDiscovery.hs new file mode 100644 index 0000000..2c2eb18 --- /dev/null +++ b/source/Network/Xmpp/Xep/ServiceDiscovery.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +-- XEP 0030: Service Discovery (disco) + +module Network.Xmpp.Xep.ServiceDiscovery + ( QueryInfoResult(..) + , Identity(..) + , queryInfo + , Item + , queryItems + , DiscoError(..) + ) + where + +import Control.Applicative((<$>)) +import Control.Monad.IO.Class +import Control.Monad.Error + +import qualified Data.Text as Text +import Data.XML.Pickle +import Data.XML.Types + +import Network.Xmpp.Pickle +import Network.Xmpp + +data DiscoError = DiscoNoQueryElement + | DiscoIQError IQError + | DiscoXMLError Element UnpickleError + + deriving (Show) + +instance Error DiscoError + +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 + +discoInfoNS :: Text.Text +discoInfoNS = "http://jabber.org/protocol/disco#info" + +infoN :: Text.Text -> Name +infoN name = (Name name (Just discoInfoNS) Nothing) + +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") + (xp4Tuple + (xpAttr "category" xpText) + (xpAttrImplied "name" xpText) + (xpAttr "type" xpText) + xpLangTag + ) + xpUnit + +xpFeatures :: PU [Node] [Text.Text] +xpFeatures = xpWrap (map fst) (map (,())) $ + xpElems (infoN "feature") + (xpAttr "var" xpText) + xpUnit + +xpQueryInfo = xpWrap (\(nd, (feats, ids)) -> QIR nd ids feats) + (\(QIR nd ids feats) -> (nd, (feats, ids))) $ + xpElem (infoN "query") + (xpAttrImplied "node" xpText) + (xp2Tuple + xpFeatures + xpIdentities + ) + +-- | Query an entity for it's identity and features +queryInfo :: Jid -- ^ Entity to query + -> Maybe Text.Text -- ^ Node + -> Xmpp (Either DiscoError QueryInfoResult) +queryInfo to node = do + res <- sendIQ' (Just to) Get Nothing queryBody + return $ case res of + Left e -> Left $ DiscoIQError 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 = xpWrap (\(jid, name, node) -> Item jid name node) + (\(Item jid name node) -> (jid, name, node)) $ + xpElemAttrs (itemsN "item") + (xp3Tuple + (xpAttr "jid" xpPrim) + (xpAttrImplied "name" xpText) + (xpAttrImplied "node" xpText)) + + +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 + -> Xmpp (Either DiscoError (Maybe Text.Text, [Item])) +queryItems to node = do + res <- sendIQ' (Just to) Get Nothing queryBody + return $ case res of + Left e -> Left $ DiscoIQError e + Right 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, [])