implement DISCO handlers

source/Network/Xmpp/Stanza.hs

@@ -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}
 -- | 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
+iqError :: StanzaErrorCondition -> IQRequest -> IQError
-iqErrorResponse condition (IQRequest iqid from _to lang _tp bd) =
+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
 --

source/Network/Xmpp/Xep/ServiceDiscovery.hs

@@ -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
 
 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 (,())) $
                 (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)
                      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)
               (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
+disco :: [Identity]
-           -> Maybe Text.Text -- ^ Node
+      -> [Text.Text]
-           -> Session
+      -> Map.Map Text.Text ([Identity], [Text.Text])
-           -> IO (Either DiscoError (Maybe Text.Text, [Item]))
+      -> (Maybe Text.Text -> IO (Maybe [Item]))
-queryItems to node session = do
+      -> Plugin
-    res <- sendIQ' (Just to) Get Nothing queryBody session
+disco ids fs ins items out = return $ Plugin'
-    return $ case res of
+                       { inHandler = \sta as -> do
-        Nothing -> Left $ DiscoIQError Nothing
+                              res <- handleInfoRequest ids fs ins out sta as
-        Just (IQResponseError e) -> Left $ DiscoIQError (Just e)
+                              concat <$>
-        Just IQResponseTimeout -> Left $ DiscoTimeout
+                                forM res (uncurry $ handleItemsRequest items out)
-        Just (IQResponseResult r) -> case iqResultPayload r of
+                       , outHandler = out
-            Nothing -> Left DiscoNoQueryElement
+                       , onSessionUp = const $ return ()
-            Just p -> case unpickleElem xpQueryItems p of
+                       }
-                Left e -> Left $ DiscoXmlError p e
-                Right r -> Right r
-  where
-    queryBody = pickleElem xpQueryItems (node, [])