fixed gatherElement bug (it was bypassing the NestingXML api)

1 files changed, 31 insertions, 70 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 36630bc7..2917d833 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -177,12 +177,12 @@ filterMapElement ret opentag empty = loop (empty `mplus` ret opentag) 1
 
 gatherElement ::
   (Monad m, MonadPlus mp) =>
-  Event -> mp Event -> MaybeT (ConduitM Event o m) (mp Event)
+  Event -> mp Event -> NestingXML o m (mp Event)
 gatherElement opentag empty = loop (empty `mplus` return opentag) 1 
  where
     loop ts 0 = return ts
     loop ts cnt = do
-        tag <- mawait
+        maybeXML (return ts) $ \tag -> do
         let ts' = mplus ts (return tag)
         case () of
          _ | eventIsEndElement tag   -> loop ts' (cnt-1)
@@ -224,68 +224,6 @@ uncontent cs = head $ map getText cs
     getText (ContentText x) = x
     getText (ContentEntity x ) = x
 
--- doIQ :: MonadIO m => Event -> MaybeT (ConduitM Event o m) ()
-doIQ session cmdChan tag@(EventBeginElement name attrs) = do
-    (_,uncontent->iq_id) <- MaybeT . return $ find (\(n,v)->isId n) attrs 
-        -- The 'id' attribute is REQUIRED for IQ stanzas. 
-        -- todo: handle it's absence more gracefully
-    case (find (\(n,v)->isType n) attrs) of
-      Just (_,[ContentText "get"]) -> discard
-      Just (_,[ContentText "set"]) -> do
-        fix $ \iqsetloop -> do
-            setwhat <- mawait
-            liftIO (putStrLn $ "IQ-set " ++ show setwhat)
-            case setwhat of
-                bind@(EventBeginElement name attrs) | isBind name -> do
-                  fix $ \again -> do
-                    rscElem <- mawait
-                    liftIO (putStrLn $ "IQ-set-bind " ++ show rscElem)
-                    case rscElem of
-                        bindchild@(EventBeginElement name _) | isResource name -> do
-                            let isContent (EventContent (ContentText v)) = return v
-                                isContent _                              = mzero
-                            xs <- filterMapElement isContent bindchild Nothing
-                            case xs of
-                                Just rsrc -> 
-                                    liftIO $ do
-                                     setResource session (L.fromChunks [S.encodeUtf8 rsrc])
-                                     jid <- getJID session
-                                     atomically $ writeTChan cmdChan (Send $ iq_bind_reply iq_id (toStrict $ L.decodeUtf8 $ L.show jid) )
-                                Nothing -> return () -- TODO: empty resource tag?
-                            void $ gatherElement bind Nothing
-                        bindchild@(EventBeginElement _ _) -> do
-                            liftIO (putStrLn "unknown bind child")
-                            gatherElement bindchild Nothing 
-                            void $ gatherElement bind Nothing
-                        EventEndElement _ -> do
-                            liftIO (putStrLn "empty bind")
-                            -- TODO
-                            -- A server that supports resource binding MUST be able to 
-                            -- generate a resource identifier on behalf of a client. A 
-                            -- resource identifier generated by the server MUST be unique 
-                            -- for that <node@domain>. 
-                        _ -> again
-                  discard
-                req@(EventBeginElement name attrs) -> do
-                    liftIO (putStrLn $ "IQ-set-unknown " ++ show req)
-                    gatherElement req Nothing
-                    discard
-                endtag@(EventEndElement _) -> do
-                    liftIO (putStrLn $ "IQ-set-empty" ++ show endtag)
-                _ -> iqsetloop
-      Just (_,[ContentText "result"]) -> discard
-      Just (_,[ContentText "error"]) -> discard
-      Just _ -> discard -- error: type must be one of {get,set,result,error}
-      Nothing -> discard -- error: The 'type' attribute is REQUIRED for IQ stanzas.
-  where
-      isId n       = n=="id"
-      isType n     = n=="type"
-      isResource n = n=="{urn:ietf:params:xml:ns:xmpp-bind}resource"
-      isBind n     = n=="{urn:ietf:params:xml:ns:xmpp-bind}bind"
-      discard = do
-            xs <- gatherElement tag Seq.empty 
-            prettyPrint "client-in: ignoring iq:" (toList xs)
-
 withJust (Just x) f = f x
 withJust Nothing  f = return ()
 
@@ -391,7 +329,30 @@ handleIQGet session cmdChan tag = do
             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
+        {-
+            IN client:
+              <iq type="get" id="purple8f8224d6"
+                ><ping xmlns="urn:xmpp:ping"/></iq>
+
+
+            OUT client:
+            <iq from='blackbird' id='purple8f8224d6' type='result'/>
+        -}
+        "{urn:xmpp:ping}ping" -> liftIO $ do
+            putStrLn ("iq-ping: "++show (stanza_id,child))
+            let mjid = lookupAttrib "from" (tagAttrs tag)
+            L.putStrLn $ "PING! from=" <++> bshow mjid
+            let pong = [ EventBeginElement "{jabber:client}iq" 
+                         $ (case mjid of
+                             Just jid -> (("to",[ContentText jid]):)
+                             _        -> id)
+                             [("type",[ContentText "result"])
+                             ,("id",[ContentText stanza_id])
+                             ,("from",[ContentText host])
+                             ]
+                      , EventEndElement "{jabber:client}iq"
+                      ]
+            atomically . writeTChan cmdChan . Send $ pong
         req -> unhandledGet req
     
 
@@ -418,8 +379,8 @@ fromClient session cmdChan = doNestingXML $ do
             stanza_lvl <- nesting
 
             let unhandledStanza = do
-                    mb <- lift . runMaybeT $ gatherElement stanza Seq.empty
-                    withJust mb $ \xs -> prettyPrint "C: " (toList xs)
+                    xs <- gatherElement stanza Seq.empty
+                    prettyPrint "unhandled-C: " (toList xs)
             case () of
              _ | stanza `isIQOf` iqTypeSet -> handleIQSet session cmdChan stanza
              _ | stanza `isIQOf` iqTypeGet -> handleIQGet session cmdChan stanza
@@ -612,11 +573,11 @@ fromPeer session = doNestingXML $ do
             stanza_lvl <- nesting
 
             let unhandledStanza = do
-                    mb <- lift . runMaybeT $ gatherElement stanza Seq.empty
-                    withJust mb $ \xs -> prettyPrint "P: " (toList xs)
+                    xs <- gatherElement stanza Seq.empty
+                    prettyPrint "P: " (toList xs)
             case () of
               _ | stanza `isPresenceOf` presenceTypeOnline
-                    -> log "peer online!" >> handlePeerPresence session stanza True
+                    -> handlePeerPresence session stanza True
               _ | stanza `isPresenceOf` presenceTypeOffline
                     -> handlePeerPresence session stanza False
               _ -> unhandledStanza