From dd9dad21a830e932ab873510c41ce1a098bc78b8 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Mon, 5 Nov 2018 05:54:00 -0500 Subject: Respond to XMPP discovery queries. --- Presence/Stanza/Parse.hs | 8 +++++ Presence/Stanza/Types.hs | 4 +++ Presence/XMPPServer.hs | 76 +++++++++++++++++++++++++++++++++++++++++------- 3 files changed, 78 insertions(+), 10 deletions(-) (limited to 'Presence') 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 -- cgit v1.2.3