implement DISCO handlers

12 years ago · 276988ceb5
2 changed files with 134 additions and 74 deletions
--- a/source/Network/Xmpp/Stanza.hs
+++ b/source/Network/Xmpp/Stanza.hs
@ -9,6 +9,7 @@ module Network.Xmpp.Stanza where
				@@ -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}
				@@ -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
 --
--- a/source/Network/Xmpp/Xep/ServiceDiscovery.hs
+++ b/source/Network/Xmpp/Xep/ServiceDiscovery.hs
@ -9,24 +9,25 @@ module Network.Xmpp.Xep.ServiceDiscovery
				@@ -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
				@@ -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 (,())) $
				@@ -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)
				@@ -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)
				@@ -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 ()
+                       }