From cff377e7d208348955c05cd4de1aa852bbfa47da Mon Sep 17 00:00:00 2001 From: joe Date: Sat, 29 Jun 2013 19:27:01 -0400 Subject: NestingXML experiment --- Presence/NestingXML.hs | 13 +++++--- Presence/XMPP.hs | 83 +++++++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 85 insertions(+), 11 deletions(-) diff --git a/Presence/NestingXML.hs b/Presence/NestingXML.hs index cf4fcd93..b90d0caa 100644 --- a/Presence/NestingXML.hs +++ b/Presence/NestingXML.hs @@ -3,6 +3,7 @@ module NestingXML where import Data.Conduit import Data.XML.Types import Control.Monad.Reader +-- import qualified Text.XML.Stream.Parse as Parse (content) type NestingXML o m a = ReaderT Int (ConduitM Event o m) a @@ -36,18 +37,21 @@ maybeXML whenNothing withJust = do xml <- awaitXML maybe whenNothing withJust xml -awaitCloser :: Monad m => Int -> NestingXML o m () +awaitCloser :: MonadIO m => Int -> NestingXML o m () awaitCloser lvl = do fix $ \loop -> do - awaitXML lvl' <- nesting - when (lvl' >= lvl) loop + when (lvl' >= lvl) $ do + withXML $ \xml -> do + liftIO $ putStrLn $ "awaitCloser: "++show (lvl',lvl,xml) + loop -nextElement :: Monad m => NestingXML o m (Maybe Event) +nextElement :: MonadIO m => NestingXML o m (Maybe Event) nextElement = do lvl <- nesting fix $ \loop -> do xml <- awaitXML + liftIO $ putStrLn $ "nextElement: "++show xml case xml of Nothing -> return Nothing Just (EventBeginElement _ _) -> return xml @@ -55,3 +59,4 @@ nextElement = do lvl' <- nesting if (lvl'>=lvl) then loop else return Nothing + diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs index c2ff6739..5c5cbaef 100644 --- a/Presence/XMPP.hs +++ b/Presence/XMPP.hs @@ -35,7 +35,7 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Todo import Control.Monad as Monad -import Text.XML.Stream.Parse +import Text.XML.Stream.Parse (parseBytes,content) import Text.XML.Stream.Render import Data.XML.Types as XML import Network.BSD (getHostName,hostName,hostAliases) @@ -51,6 +51,7 @@ import Data.Conduit.Blaze #endif import Data.List (find) import qualified Text.Show.ByteString as L +import NestingXML data Commands = Send [XML.Event] | QuitThread deriving Prelude.Show @@ -254,15 +255,72 @@ doIQ session cmdChan tag@(EventBeginElement name attrs) = do xs <- gatherElement tag Seq.empty prettyPrint "client-in: ignoring iq:" (toList xs) -fromClient :: (MonadIO m, XMPPSession session) => +withJust (Just x) f = f x +withJust Nothing f = return () + +whenJust acn f = do + x <- acn + withJust x f + +tagAttrs (EventBeginElement _ xs) = xs +tagAttrs _ = [] + +tagName (EventBeginElement n _) = n +tagName _ = "" + +handleIQSetBind session cmdChan stanza_id = do + whenJust nextElement $ \child -> do + let unhandledBind = liftIO $ putStrLn $ "unhandled-bind: "++show child + case tagName child of + "{urn:ietf:params:xml:ns:xmpp-bind}resource" + -> do + rsc <- lift content + liftIO $ do + putStrLn $ "iq-set-bind-resource " ++ show rsc + setResource session (L.fromChunks [S.encodeUtf8 rsc]) + jid <- getJID session + atomically $ writeTChan cmdChan (Send $ iq_bind_reply stanza_id (toStrict $ L.decodeUtf8 $ L.show jid) ) + _ -> unhandledBind + +handleIQSet session cmdChan tag = do + withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do + whenJust nextElement $ \child -> do + let unhandledSet = liftIO $ putStrLn ("iq-set: "++show (stanza_id,child)) + case tagName child of + "{urn:ietf:params:xml:ns:xmpp-bind}bind" + -> handleIQSetBind session cmdChan stanza_id + _ -> unhandledSet + +matchAttrib name value attrs = + case find ( (==name) . fst) attrs of + Just (_,[ContentText x]) | x==value -> True + Just (_,[ContentEntity x]) | x==value -> True + _ -> False + +lookupAttrib name attrs = + case find ( (==name) . fst) attrs of + Just (_,[ContentText x]) -> Just x + Just (_,[ContentEntity x]) -> Just x + _ -> Nothing + +iqTypeSet = "set" + +isIQOf (EventBeginElement name attrs) testType + | name=="{jabber:client}iq" + && matchAttrib "type" testType attrs + = True +isIQOf _ _ = False + +fromClient :: (MonadThrow m,MonadIO m, XMPPSession session) => session -> TChan Commands -> Sink XML.Event m () -fromClient session cmdChan = voidMaybeT $ do +fromClient session cmdChan = doNestingXML $ do let log = liftIO . L.putStrLn . ("client-in: " <++>) send = liftIO . atomically . writeTChan cmdChan . Send - mawait >>= guard . (==EventBeginDocument) + withXML $ \begindoc -> do + when (begindoc==EventBeginDocument) $ do log "begin-doc" - xml <- mawait - stream_attrs <- elementAttrs "stream" xml + withXML $ \xml -> do + withJust (elementAttrs "stream" xml) $ \stream_attrs -> do log $ "stream " <++> bshow stream_attrs host <- liftIO $ do jid <- getJID session @@ -270,6 +328,7 @@ fromClient session cmdChan = voidMaybeT $ do return (S.decodeUtf8 . head $ names) send $ greet host +{- fix $ \loop -> do xml <- mawait log $ bshow xml @@ -283,9 +342,19 @@ fromClient session cmdChan = voidMaybeT $ do prettyPrint "client-in: ignoring..." (toList xs) loop _ -> loop +-} + fix $ \loop -> do + whenJust nextElement $ \stanza -> do + stanza_lvl <- nesting + let unhandledStanza = liftIO $ putStrLn ("ignoring stanza: "++show stanza) + case () of + _ | stanza `isIQOf` iqTypeSet -> handleIQSet session cmdChan stanza + _ | otherwise -> unhandledStanza + awaitCloser stanza_lvl + loop log $ "end of stream" - xml <- mawait + withXML $ \xml -> do log $ "end-of-document: " <++> bshow xml prettyPrint prefix xs = -- cgit v1.2.3