pontarius-xmpp/source/Network/Xmpp/Xep/ServiceDiscovery.hs

{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

-- XEP 0030: Service Discovery (disco)

module Network.Xmpp.Xep.ServiceDiscovery
  ( QueryInfoResult(..)
  , Identity(..)
  , queryInfo
  , xmppQueryInfo
  , 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
import           Network.Xmpp.Concurrent
import           Network.Xmpp.Concurrent.Types
import           Network.Xmpp.Connection
import           Network.Xmpp.Marshal
import           Network.Xmpp.Types
import           Control.Concurrent.STM.TMVar

data DiscoError = DiscoNoQueryElement
                | DiscoIQError (Maybe IQError)
                | DiscoTimeout
                | 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
          -> Session
          -> IO (Either DiscoError QueryInfoResult)
queryInfo to node context = do
    res <- sendIQ' (Just to) Get Nothing queryBody context
    return $ case res of
        IQResponseError e -> Left $ DiscoIQError (Just e)
        IQResponseTimeout -> Left $ DiscoTimeout
        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
     -> TMVar Connection
     -> 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 = 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
           -> 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
        IQResponseError e -> Left $ DiscoIQError (Just e)
        IQResponseTimeout -> Left $ DiscoTimeout
        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, [])