Respond to XMPP discovery queries.

3 files changed, 78 insertions, 10 deletions

diff --git a/Presence/Stanza/Parse.hs b/Presence/Stanza/Parse.hs
index e2a9efdd..af95530f 100644
--- a/Presence/Stanza/Parse.hs
+++ b/Presence/Stanza/Parse.hs
@@ -46,6 +46,10 @@ grokStanzaIQGet stanza = do
     case tagName tag of
         "{urn:xmpp:ping}ping"     -> return Ping
         "{jabber:iq:roster}query" -> return RequestRoster
+        "{http://jabber.org/protocol/disco#items}query"
+                                  -> return RequestItems
+        "{http://jabber.org/protocol/disco#info}query"
+                                  -> return RequestInfo
         name                      -> return $ UnrecognizedQuery name
 
 grokStanzaIQResult :: XML.Event -> NestingXML o IO (Maybe StanzaType)
@@ -55,6 +59,10 @@ grokStanzaIQResult stanza = do
     case tagName tag of
         "{jabber:iq:version}query" | nameNamespace (tagName stanza)==Just "jabber:client"
             -> parseClientVersion
+        "{http://jabber.org/protocol/disco#items}query"
+            -> return $ Just Items
+        "{http://jabber.org/protocol/disco#info}query"
+            -> return $ Just Info
         _ -> return Nothing
 
 grokStanzaIQSet :: XML.Event -> NestingXML o IO (Maybe StanzaType)
diff --git a/Presence/Stanza/Types.hs b/Presence/Stanza/Types.hs
index 6b402f4d..cbb156a0 100644
--- a/Presence/Stanza/Types.hs
+++ b/Presence/Stanza/Types.hs
@@ -34,6 +34,10 @@ data StanzaType
     | Pong
     | RequestResource (Maybe Text) (Maybe Text) -- ^ Client's name for this host followed by client's requested resource id.
     | SetResource
+    | RequestItems
+    | Items
+    | RequestInfo
+    | Info
     | SessionRequest
     | UnrecognizedQuery Name
     | RequestRoster
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index f9938570..dcbc9bf5 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -1,9 +1,10 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE FlexibleInstances #-} -- instance for TChan Event
-{-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE CPP                       #-}
+{-# LANGUAGE DoAndIfThenElse           #-}
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances         #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE RankNTypes                #-}
+{-# LANGUAGE TupleSections             #-}
 module XMPPServer
     ( xmppServer
     , forkXmpp
@@ -92,7 +93,7 @@ import Data.XML.Types as XML
 import Data.Maybe
 import Data.Monoid ( (<>) )
 import Data.Text (Text)
-import qualified Data.Text as Text (pack,unpack,intercalate,drop)
+import qualified Data.Text as Text (pack,unpack,intercalate,drop,toLower)
 import qualified Data.Map as Map
 import Data.Set (Set, (\\) )
 import qualified Data.Set as Set
@@ -626,6 +627,40 @@ makePing namespace mid to from =
        , EventEndElement "{urn:xmpp:ping}ping"
        , EventEndElement $ mkname namespace "iq"]
 
+makeInfo :: Maybe Text -> Text -> Maybe Text -> [Event]
+makeInfo mid from mto = concat
+    [ [ EventBeginElement "{jabber:client}iq"
+            $ consid mid $ maybe id (\to -> (("to", [ContentText to]) :)) mto
+                            [("from", [ContentText from])
+                            ,("type", [ContentText "result"])]
+      , EventBeginElement "{http://jabber.org/protocol/disco#info}query" []
+      , EventBeginElement "{http://jabber.org/protocol/disco#info}identity"
+            [("category",[ContentText "server"])
+            ,("type",[ContentText "im"])]
+      , EventEndElement "{http://jabber.org/protocol/disco#info}identity"
+      , EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
+            [("var",[ContentText "http://jabber.org/protocol/disco#info"])]
+      , EventEndElement "{http://jabber.org/protocol/disco#info}feature" ]
+    , [] -- todo
+    , [ EventEndElement "{http://jabber.org/protocol/disco#info}query"
+      , EventEndElement "{jabber:client}iq" ]
+    ]
+
+makeItemList :: Maybe Text -> [(Text,Maybe Text)] -> Text -> Maybe Text -> [Event]
+makeItemList mid items from mto = concat
+    [ [ EventBeginElement "{jabber:client}iq"
+            $ consid mid $ maybe id (\to -> (("to", [ContentText to]) :)) mto
+                            [("from", [ContentText from])
+                            ,("type", [ContentText "result"])]
+      , EventBeginElement "{http://jabber.org/protocol/disco#items}query" []]
+    , do (jid,name) <- items
+         [ EventBeginElement "{http://jabber.org/protocol/disco#items}item"
+                $ maybe id (\n -> (("name", [ContentText n]) :)) name [ ("jid", [ContentText jid]) ],
+           EventEndElement "{http://jabber.org/protocol/disco#items}item" ]
+    , [ EventEndElement "{http://jabber.org/protocol/disco#items}query"
+      , EventEndElement "{jabber:client}iq" ]
+    ]
+
 iq_bind_reply :: Maybe Text -> Text -> [XML.Event]
 iq_bind_reply mid jid =
     [ EventBeginElement "{jabber:client}iq" (consid mid [("type",[ContentText "result"])])
@@ -908,7 +943,7 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas pp_mvar = do
                     -- kwlog $ "queuing: "++show (isempty, stanzaId stanza)
                     notping $ do
                         dup <- cloneStanza stanza
-                        let typ = Strict8.pack $ c ++ "<-"++(concat . take 1 . words $ show (stanzaType dup))++" "
+                        let typ = Strict8.pack $ c ++ "<-" ++ stanzaTypeString dup ++ " "
                             c = case auxAddr of
                                     Right _ -> "C"
                                     Left  _ -> "P"
@@ -1209,8 +1244,9 @@ monitor sv params xmpp = do
         -}
         dup <- cloneStanza stanza
 
-        forkIO $ do applyStanza sv quitVar xmpp stanza
-                    forwardStanza quitVar xmpp stanza
+        t <- forkIO $ do applyStanza sv quitVar xmpp stanza
+                         forwardStanza quitVar xmpp stanza
+        labelThread t $ "process." ++ stanzaTypeString stanza
 
         -- We need to clone in the case the stanza is passed on as for Message.
         wantStanzas <- getVerbose XJabber
@@ -1221,7 +1257,7 @@ monitor sv params xmpp = do
                       | (verbosity>=2)  = f
                       | otherwise       = return ()
         notping $ do
-        let typ = Strict8.pack $ c ++ "->"++(concat . take 1 . words $ show (stanzaType stanza))++" "
+        let typ = Strict8.pack $ c ++ "->" ++ stanzaTypeString stanza ++ " "
             c = case stanzaOrigin stanza of
                     LocalPeer       -> "*"
                     ClientOrigin {} -> "C"
@@ -1238,6 +1274,9 @@ monitor sv params xmpp = do
         where
             _ = str :: String
 
+stanzaTypeString :: StanzaWrap a -> String
+stanzaTypeString stanza = concat . take 1 . words $ show (stanzaType stanza)
+
 applyStanza :: Server PeerAddress ConnectionData releaseKey Event
                      -> TMVar ()
                      -> XMPPServerParameters
@@ -1298,6 +1337,23 @@ applyStanza sv quitVar xmpp stanza = case stanzaOrigin stanza of
                 xmppClientInformSubscription xmpp fail k stanza
             NotifyClientVersion name version -> do
                 enableClientHacks name version replyto
+            RequestInfo -> do
+                -- TODO ItemNotFound
+                me <- xmppTellMyNameToClient xmpp k
+                if fmap Text.toLower (stanzaTo stanza) == Just (Text.toLower me)
+                    then
+                        let reply = makeInfo (stanzaId stanza) me (stanzaFrom stanza)
+                        in sendReply quitVar Info reply replyto
+                    else
+                        let query = "{http://jabber.org/protocol/disco#info}info"
+                            reply = iq_service_unavailable (stanzaId stanza) me query
+                        in sendReply quitVar (Error ServiceUnavailable (head reply)) reply replyto
+            RequestItems -> do
+                -- let query = "{http://jabber.org/protocol/disco#items}query"
+                me <- xmppTellMyNameToClient xmpp k
+                let items = []
+                    reply = makeItemList (stanzaId stanza) items me (stanzaFrom stanza)
+                sendReply quitVar Items reply replyto
             UnrecognizedQuery query -> do
                 me <- xmppTellMyNameToClient xmpp k
                 let reply = iq_service_unavailable (stanzaId stanza) me query