add Network.Xmpp.Xep.ServiceDiscovery

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

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, [])