Merge remote-tracking branch 'philonous/master'

pontarius-xmpp.cabal

@@ -49,7 +49,7 @@ Library
                , stm               -any
                , xml-types         -any
                , xml-conduit       >= 1.0
-               , xml-picklers      >= 0.1
+               , xml-picklers      >= 0.2.2
                , data-default      -any
                , stringprep        >= 0.1.5
   Exposed-modules: Network.Xmpp
@@ -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.hs

@@ -144,6 +144,7 @@ module Network.Xmpp
   , fork
   , forkSession
   -- * Misc
+  , LangTag(..)
   , exampleParams
   ) where
 

source/Network/Xmpp/IM/Message.hs

@@ -19,19 +19,19 @@ data MessageThread = MessageThread
 data MessageSubject = MessageSubject (Maybe LangTag) Text
 
 xpMessageSubject :: PU [Element] MessageSubject
-xpMessageSubject = xpElems .
+xpMessageSubject = xpUnliftElems .
                    xpWrap (\(l, s) ->  MessageSubject l s)
                           (\(MessageSubject l s) -> (l,s))
                    $ xpElem "{jabber:client}subject" xpLangTag $ xpContent xpId
 
 xpMessageBody :: PU [Element] MessageBody
-xpMessageBody = xpElems .
+xpMessageBody = xpUnliftElems .
                 xpWrap (\(l, s) ->  MessageBody l s)
                           (\(MessageBody l s) -> (l,s))
                    $ xpElem "{jabber:client}body" xpLangTag $ xpContent xpId
 
 xpMessageThread :: PU [Element] MessageThread
-xpMessageThread = xpElems
+xpMessageThread = xpUnliftElems
                   . xpWrap (\(t, p) ->  MessageThread p t)
                           (\(MessageThread p t) -> (t,p))
                    $ xpElem "{jabber:client}thread"

source/Network/Xmpp/Monad.hs

@@ -90,7 +90,7 @@ pullPickle :: PU [Node] a -> XmppConMonad a
 pullPickle p = do
     res <- unpickleElem p <$> pullElement
     case res of
-        Left e -> liftIO . Ex.throwIO $ StreamXMLError e
+        Left e -> liftIO . Ex.throwIO $ StreamXMLError (show e)
         Right r -> return r
 
 -- Pulls a stanza (or stream error) from the stream. Throws an error on a stream

source/Network/Xmpp/Pickle.hs

@@ -70,11 +70,11 @@ right (Right r) = r
 
 unpickleElem' :: PU [Node] c -> Element -> c
 unpickleElem' p x = case unpickle (xpNodeElem p) x of
-  Left l -> error $ l ++ "\n  saw: " ++ ppElement x
+  Left l -> error $ (show l) ++ "\n  saw: " ++ ppElement x
   Right r -> r
 
 -- Given a pickler and an element, produces an object.
-unpickleElem :: PU [Node] a -> Element -> Either String a
+unpickleElem :: PU [Node] a -> Element -> Either UnpickleError a
 unpickleElem p x = unpickle (xpNodeElem p) x
 
 -- Given a pickler and an object, produces an Element.

source/Network/Xmpp/Stream.hs

@@ -33,7 +33,7 @@ streamUnpickleElem :: PU [Node] a
                    -> StreamSink a
 streamUnpickleElem p x = do
     case unpickleElem p x of
-        Left l -> throwError $ StreamXMLError l
+        Left l -> throwError $ StreamXMLError (show l)
         Right r -> return r
 
 -- This is the conduit sink that handles the stream XML events. We extend it

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