implemented service-unavailable reply.

1 files changed, 36 insertions, 1 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 36d9bf74..fd528037 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -323,7 +323,10 @@ lookupAttrib name attrs =
         Just (_,[ContentEntity x]) -> Just x
         _                          -> Nothing
     
-iqTypeSet = "set"
+iqTypeSet    = "set"
+iqTypeGet    = "get"
+iqTypeResult = "result"
+iqTypeError  = "error"
 
 isIQOf (EventBeginElement name attrs) testType 
     | name=="{jabber:client}iq" 
@@ -331,6 +334,37 @@ isIQOf (EventBeginElement name attrs) testType
     = True
 isIQOf _ _ = False
 
+iq_service_unavailable host iq_id mjid req =
+    [ EventBeginElement "{jabber:client}iq" 
+        [("type",[ContentText "error"])
+        ,("id",[ContentText iq_id])
+        -- , 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"
+    ]
+
+handleIQGet session cmdChan tag = do
+    withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do
+    whenJust nextElement $ \child -> do
+    host <- liftIO $ do
+        jid <- getJID session
+        names <- getNamesForPeer (peer jid)
+        return (S.decodeUtf8 . head $ names)
+    let unhandledGet req = do
+            liftIO $ putStrLn ("iq-get: "++show (stanza_id,child))
+            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 $ putStrLn "iq-get-query-items"
+        -- "{urn:xmpp:ping}ping" -> todo
+        req -> unhandledGet req
+    
+
 fromClient :: (MonadThrow m,MonadIO m, XMPPSession session) => 
     session -> TChan Commands -> Sink XML.Event m ()
 fromClient session cmdChan = doNestingXML $ do
@@ -358,6 +392,7 @@ fromClient session cmdChan = doNestingXML $ do
                     withJust mb $ \xs -> prettyPrint "C: " (toList xs)
             case () of
              _ | stanza `isIQOf` iqTypeSet -> handleIQSet session cmdChan stanza
+             _ | stanza `isIQOf` iqTypeGet -> handleIQGet session cmdChan stanza
              _ | otherwise                 -> unhandledStanza
 
             awaitCloser stanza_lvl