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
  , Item(..)
  , queryItems
  , DiscoError(..)
  , disco
  )
  where

import           Control.Applicative ((<$>))
import           Control.Monad.Except
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.Types
import           Network.Xmpp.Concurrent.Types
import           Network.Xmpp.Marshal
import           Network.Xmpp.Plugins
import           Network.Xmpp.Stanza

data DiscoError = DiscoNoQueryElement
                | DiscoIQError (Maybe IQError)
                | DiscoTimeout
                | DiscoXmlError Element UnpickleError

                deriving (Show)

-- 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 (Either XmppFailure ()) )
     -> 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 (Either XmppFailure ()))
                   -> Stanza
                   -> [Annotation]
                   -> IO [Annotated Stanza]
handleItemsRequest getItems = handleIQRequest Get pickler $ \iqr (node, _) _ -> do
    mbIs <- getItems node
    case mbIs 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, l) -> Ident cat n tp l) . fst)
               (map $ \(Ident cat n tp l) -> ((cat, n, tp, l),())) $
              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 :: PU [Node] QueryInfoResult
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
                     )

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")
           (xp3Tuple
              (xpAttr "jid" xpJid)
              (xpAttrImplied "name" xpText)
              (xpAttrImplied "node" xpText))


xpQueryItems :: PU [Node] (Maybe Text.Text, [Item])
xpQueryItems = xpElem (itemsN "query")
                 (xpAttrImplied "node" xpText)
                 (xpAll xpItem)


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 ()
                       }