send service-unavailable responses for iq queries

1 files changed, 71 insertions, 34 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index ceb83476..ccdffabe 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -103,6 +103,7 @@ data Stanza
 -}
 
 data StanzaType = Unrecognized | Ping | Pong | RequestResource (Maybe Text) | SetResource
+                  | SessionRequest | UnrecognizedQuery Name | Error
  deriving Show
 
 data StanzaOrigin = LocalPeer | NetworkOrigin ConnectionKey (TChan Stanza)
@@ -173,7 +174,7 @@ grokStanzaIQGet stanza = do
     flip (maybe $ return Nothing)  mtag $ \tag -> do
     case tagName tag of
         "{urn:xmpp:ping}ping" -> return $ Just Ping
-        _ -> return Nothing
+        name -> return . Just $ UnrecognizedQuery name
 
 grokStanzaIQResult :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType)
 grokStanzaIQResult stanza = do
@@ -195,6 +196,8 @@ grokStanzaIQSet stanza = do
                     return . Just $ RequestResource (Just rsc)
                 Just _ -> return Nothing
                 Nothing -> return . Just $ RequestResource Nothing
+        "{urn:ietf:params:xml:ns:xmpp-session}session" -> do
+            return $ Just SessionRequest
         _ -> return Nothing
 
 
@@ -359,32 +362,6 @@ greet' namespace host =
 consid Nothing = id
 consid (Just sid) = (("id",[ContentText sid]):)
 
-iq_bind_reply :: Maybe Text -> Text -> [XML.Event]
-iq_bind_reply mid jid =
-    [ EventBeginElement "{jabber:client}iq" (consid mid [("type",[ContentText "result"])])
-    , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
-        [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])]
-    , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}jid" []
-    , EventContent (ContentText jid)
-    , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}jid"
-    , EventEndElement  "{urn:ietf:params:xml:ns:xmpp-bind}bind"
-    , EventEndElement "{jabber:client}iq"
-    ]
-
-{-
-greet namespace =
-    [ EventBeginDocument
-    , EventBeginElement (streamP "stream")
-        [ attr "xmlns"   namespace
-        , attr "version" "1.0"
-        ]
-    ]
--}
-
-goodbye = 
-    [ EventEndElement (streamP "stream")
-    , EventEndDocument
-    ]
 
 data XMPPState
     = PingSlot
@@ -407,6 +384,7 @@ makePing namespace mid to from =
        , EventEndElement $ mkname namespace "iq"]
 
 makePong namespace mid to from =
+       -- Note: similar to session reply
        [ EventBeginElement (mkname namespace "iq")
          $(case mid of
                Just c -> (("id",[ContentText c]):)
@@ -418,6 +396,56 @@ makePong namespace mid to from =
        , EventEndElement (mkname namespace "iq")
        ]
 
+iq_bind_reply :: Maybe Text -> Text -> [XML.Event]
+iq_bind_reply mid jid =
+    [ EventBeginElement "{jabber:client}iq" (consid mid [("type",[ContentText "result"])])
+    , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
+        [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])]
+    , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}jid" []
+    , EventContent (ContentText jid)
+    , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}jid"
+    , EventEndElement  "{urn:ietf:params:xml:ns:xmpp-bind}bind"
+    , EventEndElement "{jabber:client}iq"
+    ]
+
+iq_session_reply mid host =
+    -- Note: similar to Pong
+    [ EventBeginElement "{jabber:client}iq" 
+        (consid mid [("from",[ContentText host])
+                    ,("type",[ContentText "result"])
+                    ])
+    , EventEndElement "{jabber:client}iq"
+    ]
+
+iq_service_unavailable mid host {- mjid -} req =
+    [ EventBeginElement "{jabber:client}iq" 
+        (consid mid [("type",[ContentText "error"])
+                    -- , TODO: set "from" if isJust mjid
+                    ])
+    , EventBeginElement req []
+    , EventEndElement req
+    , EventBeginElement "{jabber:client}error" [("type",[ContentText "cancel"])]
+    , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable" []
+    , EventEndElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable"
+    , EventEndElement "{jabber:client}error"
+    , EventEndElement "{jabber:client}iq"
+    ]
+
+
+{-
+greet namespace =
+    [ EventBeginDocument
+    , EventBeginElement (streamP "stream")
+        [ attr "xmlns"   namespace
+        , attr "version" "1.0"
+        ]
+    ]
+-}
+
+goodbye = 
+    [ EventEndElement (streamP "stream")
+    , EventEndDocument
+    ]
 
 forkConnection :: Server ConnectionKey
                 -> ConnectionKey
@@ -569,14 +597,23 @@ monitor sv params = do
             _ -> return ()
       , readTChan stanzas >>= \stanza -> return $ do
         forkIO $ do
-            case (stanzaType stanza,stanzaOrigin stanza) of
-                (RequestResource wanted, NetworkOrigin k@(ClientKey{}) replyto) -> do
-                    sock <- socketFromKey sv k
-                    rsc <- getResourceName sock wanted
-                    let reply = iq_bind_reply (stanzaId stanza) rsc
-                    sendReply quitVar SetResource reply replyto
+            case stanzaOrigin stanza of
+                NetworkOrigin k@(ClientKey {}) replyto -> 
+                    case stanzaType stanza of
+                        RequestResource wanted -> do
+                            sock <- socketFromKey sv k
+                            rsc <- getResourceName sock wanted
+                            let reply = iq_bind_reply (stanzaId stanza) rsc
+                            sendReply quitVar SetResource reply replyto
+                        SessionRequest -> do
+                            let reply = iq_session_reply (stanzaId stanza) "localhost"
+                            sendReply quitVar Pong reply replyto
+                        UnrecognizedQuery query -> do
+                            let reply = iq_service_unavailable (stanzaId stanza) "localhost" query
+                            sendReply quitVar Error reply replyto
+                        _ -> return ()
                 _ -> return ()
-        let typ = Strict8.pack $ c ++ "->"++(show (stanzaType stanza))++" "
+        let typ = Strict8.pack $ c ++ "->"++(concat . take 1 . words $ show (stanzaType stanza))++" "
             c = case stanzaOrigin stanza of
                     LocalPeer -> "*"
                     NetworkOrigin (ClientKey {}) _ -> "C"