Send service-unavailable on unsupported peer iq requests.

1 files changed, 29 insertions, 20 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 179ffd6b..8589999b 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -890,30 +890,17 @@ handlePeerIQGet :: (JabberPeerSession session, MonadIO m) =>
 handlePeerIQGet session tag = do
     withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do
     whenJust nextElement $ \child -> do
-    host <- liftIO $ do
-        names <- getNamesForPeer (peerAddress session)
-        return (S.decodeUtf8 . head $ names)
     let unhandledGet req = do
-            liftIO $ debugStr ("iq-get: "++show (stanza_id,child))
-            -- TODO: send service-unavailable to peer (See example 9 of XEP-0199)
-            --   Unsupported 
+            liftIO $ debugStr ("iq-peer-get: "++show (stanza_id,child))
+            liftIO $
+              sendPeerMessage session (Unsupported (JID Nothing LocalHost Nothing)
+                                                   (JID Nothing (peerAddress session) Nothing)
+                                                   (Just (ContentText stanza_id))
+                                                   req)
             -- Client equiv: liftIO . atomically . writeTChan cmdChan . Send $ iq_service_unavailable host stanza_id Nothing req
     case tagName child of
         -- "{http://jabber.org/protocol/disco#items}query" -> liftIO $ debugStr "iq-get-query-items"
         "{urn:xmpp:ping}ping" -> liftIO $ do
-            {-
-            let mjid = lookupAttrib "from" (tagAttrs tag)
-            let pong = [ EventBeginElement "{jabber:server}iq" 
-                         $ (case mjid of
-                             Just jid -> (attr "to" jid :)
-                             _        -> id               )
-                             [ attr "type" "result"
-                             , attr "id"   stanza_id
-                             , attr "from" host
-                             ]
-                      , EventEndElement "{jabber:server}iq"
-                      ]
-            -}
             sendPeerMessage session (Pong (JID Nothing LocalHost Nothing)
                                           (JID Nothing (peerAddress session) Nothing)
                                           (Just (ContentText stanza_id)))
@@ -1092,6 +1079,28 @@ toPeer sock cache chan fail = do
                              ]
                       , EventEndElement "{jabber:server}iq"
                       ]
+        sendUnsupported from to mid tag =
+            sendOrFail (xmlifyUnsupported sock from to mid tag)
+                       (Unsupported from to mid tag)
+         where
+            xmlifyUnsupported sock from to mid req = 
+                return $ 
+                    [ EventBeginElement "{jabber:server}iq" 
+                     $ (case mid of
+                        Just c -> (("id",[c]):)
+                        _      -> id               )
+                        [("type",[ContentText "error"])
+                        , attr "to"   (toStrict $ L.decodeUtf8 $ L.show to)
+                        , attr "from" (toStrict $ L.decodeUtf8 $ L.show from)
+                        ]
+                    , EventBeginElement req []
+                    , EventEndElement req
+                    , EventBeginElement "{jabber:server}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:server}error"
+                    , EventEndElement "{jabber:server}iq"
+                    ]
 
 
     send greetPeer
@@ -1130,7 +1139,7 @@ toPeer sock cache chan fail = do
             sendApproval False from to
           OutBoundMessage msg -> sendMessage msg
           Pong from to mid -> sendPong from to mid
-          Unsupported _ _ _ _ -> todo
+          Unsupported from to mid tag -> sendUnsupported from to mid tag
           Disconnect -> return ()
         when (not . isQuitCommand $ event) loop
     return ()