From d0eb0e8d0db2fdd55511d8176467675816b0a179 Mon Sep 17 00:00:00 2001 From: joe Date: Mon, 1 Jul 2013 00:48:20 -0400 Subject: fixed gatherElement bug (it was bypassing the NestingXML api) --- Presence/XMPP.hs | 101 +++++++++++++++++-------------------------------------- 1 file changed, 31 insertions(+), 70 deletions(-) (limited to 'Presence') 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 . - _ -> 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: + + + + OUT client: + + -} + "{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 -- cgit v1.2.3