From 72925feb72a0eee9e809aeb4fbe078e257b4881c Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Tue, 26 Jul 2011 13:26:41 +0200 Subject: [PATCH] rewrote xmlReader (now eventConsumer), its depending functions and some enumeration-related types --- Network/XMPP/Session.hs | 290 ++++++++++++++++++++-------------------- Network/XMPP/Stream.hs | 168 +++++++++++------------ Network/XMPP/Types.hs | 12 +- 3 files changed, 226 insertions(+), 244 deletions(-) diff --git a/Network/XMPP/Session.hs b/Network/XMPP/Session.hs index ff425c0..19d2d9d 100644 --- a/Network/XMPP/Session.hs +++ b/Network/XMPP/Session.hs @@ -465,93 +465,93 @@ processEvent e = get >>= \ state -> lift $ liftIO $ send ("" ++ (CBBS.encode ("n,,n=" ++ userName ++ ",r=" ++ (toString rValue))) ++ "") handleOrTLSCtx return Nothing - IEE (EnumeratorXML (XEBeginStream stream)) -> do + IEE (EnumeratorBeginStream from to id ver lang namespace) -> do put $ state { stateStreamState = PreFeatures (1.0) } return Nothing - IEE (EnumeratorXML (XEFeatures features)) -> do - let PreFeatures streamProperties = stateStreamState state - case stateTLSState state of - NoTLS -> let callback = fromJust $ stateOpenStreamsCallback state in do - ((), clientState) <- lift $ runStateT (callback $ OpenStreamSuccess streamProperties "TODO") (stateClientState state) - put $ state { stateClientState = clientState - , stateStreamState = PostFeatures streamProperties "TODO" } - return Nothing - _ -> case stateAuthenticationState state of - AuthenticatedUnbound _ resource -> do -- TODO: resource - case resource of - Nothing -> do - lift $ liftIO $ send ("") handleOrTLSCtx - return () - _ -> do - lift $ liftIO $ send ("" ++ fromJust resource ++ "") handleOrTLSCtx - return () - id <- liftIO $ nextID $ stateIDGenerator state - lift $ liftIO $ send ("" ++ "") handleOrTLSCtx - - -- TODO: Execute callback on iq result - - let callback = fromJust $ stateAuthenticateCallback state in do -- TODO: streamProperties "TODO" after success - ((), clientState) <- lift $ runStateT (callback $ AuthenticateSuccess streamProperties "TODO" "todo") (stateClientState state) -- get proper resource value when moving to iq result - put $ state { stateClientState = clientState - , stateStreamState = PostFeatures streamProperties "TODO" } - state' <- get - return Nothing - _ -> do - let callback = fromJust $ stateTLSSecureStreamsCallback state in do - ((), clientState) <- lift $ runStateT (callback $ SecureWithTLSSuccess streamProperties "TODO") (stateClientState state) - put $ state { stateClientState = clientState - , stateStreamState = PostFeatures streamProperties "TODO" } - return Nothing - - -- TODO: Can we assume that it's safe to start to enumerate on handle when it - -- might not have exited? - IEE (EnumeratorXML XEProceed) -> do - let Connected (ServerAddress hostName _) handle = stateConnectionState state - tlsCtx <- lift $ liftIO $ do - gen <- newGenIO :: IO SystemRandom -- TODO: Investigate limitations - clientContext <- client tlsParams gen handle - handshake clientContext - return clientContext - put $ (defaultState (stateChannel state) (stateThreadID state) (stateClientHandlers state) (stateClientState state) (stateIDGenerator state)) { stateTLSState = PostHandshake tlsCtx, stateConnectionState = (stateConnectionState state), stateTLSSecureStreamsCallback = (stateTLSSecureStreamsCallback state) } - threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Right tlsCtx) -- double code - lift $ liftIO $ putStrLn "00000000000000000000000000000000" - lift $ liftIO $ swapMVar (stateThreadID state) threadID -- return value not used - lift $ liftIO $ putStrLn "00000000000000000000000000000000" - lift $ liftIO $ threadDelay 1000000 - lift $ liftIO $ putStrLn "00000000000000000000000000000000" - lift $ liftIO $ send ("") (Right tlsCtx) - lift $ liftIO $ putStrLn "00000000000000000000000000000000" - return Nothing - - IEE (EnumeratorXML (XEChallenge (Chal challenge))) -> do - lift $ liftIO $ putStrLn challenge - let Connected (ServerAddress hostName _) _ = stateConnectionState state - let challenge' = CBBS.decode challenge - case stateAuthenticationState state of - AuthenticatingPreChallenge1 userName password resource -> do - id <- liftIO $ nextID $ stateIDGenerator state - -- TODO: replyToChallenge - return () - AuthenticatingPreChallenge2 userName password resource -> do - -- This is not the first challenge; [...] - -- TODO: Can we assume "rspauth"? - lift $ liftIO $ send "" handleOrTLSCtx - put $ state { stateAuthenticationState = AuthenticatingPreSuccess userName password resource } - return () - return Nothing - - -- We have received a SASL "success" message over a secured connection - -- TODO: Parse the success message? - -- TODO: ? - IEE (EnumeratorXML (XESuccess (Succ _))) -> do - let serverHost = "jonkristensen.com" - let AuthenticatingPreSuccess userName _ resource = stateAuthenticationState state in do - lift $ liftIO $ send ("") handleOrTLSCtx - put $ state { stateAuthenticationState = AuthenticatedUnbound userName resource } - return Nothing +-- IEE (EnumeratorXML (XEFeatures features)) -> do +-- let PreFeatures streamProperties = stateStreamState state +-- case stateTLSState state of +-- NoTLS -> let callback = fromJust $ stateOpenStreamsCallback state in do +-- ((), clientState) <- lift $ runStateT (callback $ OpenStreamSuccess streamProperties "TODO") (stateClientState state) +-- put $ state { stateClientState = clientState +-- , stateStreamState = PostFeatures streamProperties "TODO" } +-- return Nothing +-- _ -> case stateAuthenticationState state of +-- AuthenticatedUnbound _ resource -> do -- TODO: resource +-- case resource of +-- Nothing -> do +-- lift $ liftIO $ send ("") handleOrTLSCtx +-- return () +-- _ -> do +-- lift $ liftIO $ send ("" ++ fromJust resource ++ "") handleOrTLSCtx +-- return () +-- id <- liftIO $ nextID $ stateIDGenerator state +-- lift $ liftIO $ send ("" ++ "") handleOrTLSCtx +-- +-- -- TODO: Execute callback on iq result +-- +-- let callback = fromJust $ stateAuthenticateCallback state in do -- TODO: streamProperties "TODO" after success +-- ((), clientState) <- lift $ runStateT (callback $ AuthenticateSuccess streamProperties "TODO" "todo") (stateClientState state) -- get proper resource value when moving to iq result +-- put $ state { stateClientState = clientState +-- , stateStreamState = PostFeatures streamProperties "TODO" } +-- state' <- get +-- return Nothing +-- _ -> do +-- let callback = fromJust $ stateTLSSecureStreamsCallback state in do +-- ((), clientState) <- lift $ runStateT (callback $ SecureWithTLSSuccess streamProperties "TODO") (stateClientState state) +-- put $ state { stateClientState = clientState +-- , stateStreamState = PostFeatures streamProperties "TODO" } +-- return Nothing +-- +-- -- TODO: Can we assume that it's safe to start to enumerate on handle when it +-- -- might not have exited? +-- IEE (EnumeratorXML XEProceed) -> do +-- let Connected (ServerAddress hostName _) handle = stateConnectionState state +-- tlsCtx <- lift $ liftIO $ do +-- gen <- newGenIO :: IO SystemRandom -- TODO: Investigate limitations +-- clientContext <- client tlsParams gen handle +-- handshake clientContext +-- return clientContext +-- put $ (defaultState (stateChannel state) (stateThreadID state) (stateClientHandlers state) (stateClientState state) (stateIDGenerator state)) { stateTLSState = PostHandshake tlsCtx, stateConnectionState = (stateConnectionState state), stateTLSSecureStreamsCallback = (stateTLSSecureStreamsCallback state) } +-- threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Right tlsCtx) -- double code +-- lift $ liftIO $ putStrLn "00000000000000000000000000000000" +-- lift $ liftIO $ swapMVar (stateThreadID state) threadID -- return value not used +-- lift $ liftIO $ putStrLn "00000000000000000000000000000000" +-- lift $ liftIO $ threadDelay 1000000 +-- lift $ liftIO $ putStrLn "00000000000000000000000000000000" +-- lift $ liftIO $ send ("") (Right tlsCtx) +-- lift $ liftIO $ putStrLn "00000000000000000000000000000000" +-- return Nothing +-- +-- IEE (EnumeratorXML (XEChallenge (Chal challenge))) -> do +-- lift $ liftIO $ putStrLn challenge +-- let Connected (ServerAddress hostName _) _ = stateConnectionState state +-- let challenge' = CBBS.decode challenge +-- case stateAuthenticationState state of +-- AuthenticatingPreChallenge1 userName password resource -> do +-- id <- liftIO $ nextID $ stateIDGenerator state +-- -- TODO: replyToChallenge +-- return () +-- AuthenticatingPreChallenge2 userName password resource -> do +-- -- This is not the first challenge; [...] +-- -- TODO: Can we assume "rspauth"? +-- lift $ liftIO $ send "" handleOrTLSCtx +-- put $ state { stateAuthenticationState = AuthenticatingPreSuccess userName password resource } +-- return () +-- return Nothing +-- +-- -- We have received a SASL "success" message over a secured connection +-- -- TODO: Parse the success message? +-- -- TODO: ? +-- IEE (EnumeratorXML (XESuccess (Succ _))) -> do +-- let serverHost = "jonkristensen.com" +-- let AuthenticatingPreSuccess userName _ resource = stateAuthenticationState state in do +-- lift $ liftIO $ send ("") handleOrTLSCtx +-- put $ state { stateAuthenticationState = AuthenticatedUnbound userName resource } +-- return Nothing IEE EnumeratorDone -> -- TODO: Exit? @@ -561,67 +561,67 @@ processEvent e = get >>= \ state -> -- XML EVENTS -- --------------------------------------------------------------------------- - -- Ignore id="bind_1" and session IQ result, otherwise create client event - IEE (EnumeratorXML (XEIQ iqEvent)) -> - case shouldIgnoreIQ iqEvent of - True -> - return Nothing - False -> do - let stanzaID' = iqID iqEvent - let newTimeouts = case stanzaID' of - Just stanzaID'' -> - case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of - True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state) - False -> (stateTimeoutStanzaIDs state) - Nothing -> (stateTimeoutStanzaIDs state) - let iqReceivedFunctions = map (\ x -> iqReceived x) (stateClientHandlers state) - let functions = map (\ x -> case x of - Just f -> Just (f iqEvent) - Nothing -> Nothing) iqReceivedFunctions - let functions' = case lookup (fromJust $ iqID $ iqEvent) (stateIQCallbacks state) of - Just f -> (Just (f $ iqEvent)):functions - Nothing -> functions - let clientState = stateClientState state - clientState' <- sendToClient functions' clientState - put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts } - return Nothing - - -- TODO: Known bug - does not work with PresenceError - - IEE (EnumeratorXML (XEPresence (Right presenceEvent))) -> do - let stanzaID' = presenceID $ presenceEvent - let newTimeouts = case stanzaID' of - Just stanzaID'' -> - case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of - True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state) - False -> (stateTimeoutStanzaIDs state) - Nothing -> (stateTimeoutStanzaIDs state) - let presenceReceivedFunctions = map (\ x -> presenceReceived x) (stateClientHandlers state) - let functions = map (\ x -> case x of - Just f -> Just (f presenceEvent) - Nothing -> Nothing) presenceReceivedFunctions - let clientState = stateClientState state -- ClientState s m - clientState' <- sendToClient functions clientState - put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts } - return Nothing - - -- TODO: Does not work with message errors - IEE (EnumeratorXML (XEMessage (Right messageEvent))) -> do - let stanzaID' = messageID $ messageEvent - let newTimeouts = case stanzaID' of - Just stanzaID'' -> - case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of - True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state) - False -> (stateTimeoutStanzaIDs state) - Nothing -> (stateTimeoutStanzaIDs state) - let messageReceivedFunctions = map (\ x -> messageReceived x) (stateClientHandlers state) - let functions = map (\ x -> case x of - Just f -> Just (f messageEvent) - Nothing -> Nothing) messageReceivedFunctions - let clientState = stateClientState state -- ClientState s m - clientState' <- sendToClient functions clientState - put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts } - return Nothing +-- -- Ignore id="bind_1" and session IQ result, otherwise create client event +-- IEE (EnumeratorXML (XEIQ iqEvent)) -> +-- case shouldIgnoreIQ iqEvent of +-- True -> +-- return Nothing +-- False -> do +-- let stanzaID' = iqID iqEvent +-- let newTimeouts = case stanzaID' of +-- Just stanzaID'' -> +-- case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of +-- True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state) +-- False -> (stateTimeoutStanzaIDs state) +-- Nothing -> (stateTimeoutStanzaIDs state) +-- let iqReceivedFunctions = map (\ x -> iqReceived x) (stateClientHandlers state) +-- let functions = map (\ x -> case x of +-- Just f -> Just (f iqEvent) +-- Nothing -> Nothing) iqReceivedFunctions +-- let functions' = case lookup (fromJust $ iqID $ iqEvent) (stateIQCallbacks state) of +-- Just f -> (Just (f $ iqEvent)):functions +-- Nothing -> functions +-- let clientState = stateClientState state +-- clientState' <- sendToClient functions' clientState +-- put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts } +-- return Nothing +-- +-- -- TODO: Known bug - does not work with PresenceError +-- +-- IEE (EnumeratorXML (XEPresence (Right presenceEvent))) -> do +-- let stanzaID' = presenceID $ presenceEvent +-- let newTimeouts = case stanzaID' of +-- Just stanzaID'' -> +-- case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of +-- True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state) +-- False -> (stateTimeoutStanzaIDs state) +-- Nothing -> (stateTimeoutStanzaIDs state) +-- let presenceReceivedFunctions = map (\ x -> presenceReceived x) (stateClientHandlers state) +-- let functions = map (\ x -> case x of +-- Just f -> Just (f presenceEvent) +-- Nothing -> Nothing) presenceReceivedFunctions +-- let clientState = stateClientState state -- ClientState s m +-- clientState' <- sendToClient functions clientState +-- put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts } +-- return Nothing +-- +-- -- TODO: Does not work with message errors +-- IEE (EnumeratorXML (XEMessage (Right messageEvent))) -> do +-- let stanzaID' = messageID $ messageEvent +-- let newTimeouts = case stanzaID' of +-- Just stanzaID'' -> +-- case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of +-- True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state) +-- False -> (stateTimeoutStanzaIDs state) +-- Nothing -> (stateTimeoutStanzaIDs state) +-- let messageReceivedFunctions = map (\ x -> messageReceived x) (stateClientHandlers state) +-- let functions = map (\ x -> case x of +-- Just f -> Just (f messageEvent) +-- Nothing -> Nothing) messageReceivedFunctions +-- let clientState = stateClientState state -- ClientState s m +-- clientState' <- sendToClient functions clientState +-- put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts } +-- return Nothing IEC (CEPresence presence stanzaCallback timeoutCallback streamErrorCallback) -> do presence' <- case presenceID $ presence of diff --git a/Network/XMPP/Stream.hs b/Network/XMPP/Stream.hs index 5d86039..43431f7 100644 --- a/Network/XMPP/Stream.hs +++ b/Network/XMPP/Stream.hs @@ -8,7 +8,6 @@ module Network.XMPP.Stream ( isTLSSecured, xmlEnumerator, -xmlReader, presenceToXML, iqToXML, messageToXML, @@ -22,7 +21,7 @@ versionFromNumbers import Network.XMPP.Address hiding (fromString) import qualified Network.XMPP.Address as X -import Network.XMPP.Types +import Network.XMPP.Types hiding (Continue) import Network.XMPP.Utilities import Network.XMPP.TLS import Network.XMPP.Stanza @@ -39,8 +38,6 @@ import Text.XML.Enumerator.Document (fromEvents) import qualified Data.ByteString as DB import qualified Data.ByteString.Lazy as DBL (ByteString, append, pack, fromChunks, toChunks, null) import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack) -import qualified Data.Enumerator as E -import qualified Data.Enumerator.List as EL import qualified Data.List as DL import qualified Data.Text as DT import qualified Data.Text.Lazy as DTL @@ -56,6 +53,11 @@ import Text.Parsec.ByteString (GenParser) import qualified Data.ByteString.Char8 as DBC (pack) +import Data.Enumerator ((>>==), Iteratee (..), Enumeratee, Step (..), Enumerator (..), Stream (Chunks), returnI) +import qualified Data.Enumerator.List as DEL (head) + +import Control.Exception.Base (SomeException) + isTLSSecured :: TLSState -> Bool isTLSSecured (PostHandshake _) = True @@ -69,9 +71,9 @@ xmlEnumerator :: Chan (InternalEvent s m) -> Either Handle TLSCtx -> IO () xmlEnumerator c s = do enumeratorResult <- case s of Left handle -> run $ enumHandle 1 handle $$ joinI $ - parseBytes decodeEntities $$ xmlReader c + parseBytes decodeEntities $$ eventConsumer c [] 0 Right tlsCtx -> run $ enumTLS tlsCtx $$ joinI $ - parseBytes decodeEntities $$ xmlReader c + parseBytes decodeEntities $$ eventConsumer c [] 0 case enumeratorResult of Right _ -> writeChan c $ IEE EnumeratorDone @@ -79,94 +81,79 @@ xmlEnumerator c s = do writeChan c $ IEE (EnumeratorException e) where -- Behaves like enumHandle, but reads from the TLS context instead - enumTLS :: TLSCtx -> E.Enumerator DB.ByteString IO b + enumTLS :: TLSCtx -> Enumerator DB.ByteString IO b enumTLS c s = loop c s - loop :: TLSCtx -> E.Step DB.ByteString IO b -> E.Iteratee DB.ByteString IO b - loop c (E.Continue k) = do + loop :: TLSCtx -> Step DB.ByteString IO b -> Iteratee DB.ByteString IO b + loop c (Continue k) = do d <- recvData c case DBL.null d of - True -> loop c (E.Continue k) - False -> k (E.Chunks $ DBL.toChunks d) E.>>== loop c - loop _ step = E.returnI step - - -xmlReader :: Chan (InternalEvent s m) -> Iteratee Event IO (Maybe Event) - -xmlReader c = xmlReader_ c [] 0 - - -xmlReader_ :: Chan (InternalEvent s m) -> [Event] -> Int -> - Iteratee Event IO (Maybe Event) - -xmlReader_ ch [EventBeginDocument] 0 = xmlReader_ ch [] 0 - --- TODO: Safe to start change level here? We are doing this since the stream can --- restart. --- TODO: l < 2? -xmlReader_ ch [EventBeginElement name attribs] l - | l < 3 && nameLocalName name == DT.pack "stream" && - namePrefix name == Just (DT.pack "stream") = do - liftIO $ writeChan ch $ IEE $ EnumeratorXML $ XEBeginStream $ "StreamTODO" - xmlReader_ ch [] 1 - -xmlReader_ ch [EventEndElement name] 1 - | namePrefix name == Just (DT.pack "stream") && - nameLocalName name == DT.pack "stream" = do - liftIO $ writeChan ch $ IEE $ EnumeratorXML $ XEEndStream - return Nothing - --- Check if counter is one to forward it to related function. --- Should replace "reverse ((EventEndElement n):es)" with es --- ... -xmlReader_ ch ((EventEndElement n):es) 1 - | nameLocalName n == DT.pack "proceed" = do - liftIO $ writeChan ch $ IEE $ EnumeratorXML $ XEProceed - E.yield Nothing (E.Chunks []) - | otherwise = do - -- liftIO $ putStrLn "Got an IEX Event..." - liftIO $ writeChan ch $ IEE $ EnumeratorXML $ (processEventList (DL.reverse ((EventEndElement n):es))) - xmlReader_ ch [] 1 - --- Normal condition, buffer the event to events list. -xmlReader_ ch es co = do - head <- EL.head - let co' = counter co head - -- liftIO $ putStrLn $ show co' ++ "\t" ++ show head -- for test - case head of - Just e -> xmlReader_ ch (e:es) co' - Nothing -> xmlReader_ ch es co' - - --- TODO: Generate real event. -processEventList :: [Event] -> XMLEvent -processEventList e - | namePrefix name == Just (DT.pack "stream") && - nameLocalName name == DT.pack "features" = XEFeatures "FeaturesTODO" - | nameLocalName name == DT.pack "challenge" = - let EventContent (ContentText c) = head es in XEChallenge $ Chal $ DT.unpack c - | nameLocalName name == DT.pack "success" = - let EventContent (ContentText c) = head es in XESuccess $ Succ $ "" -- DT.unpack c - | nameLocalName name == DT.pack "iq" = XEIQ $ parseIQ $ eventsToElement e - | nameLocalName name == DT.pack "presence" = XEPresence $ parsePresence $ eventsToElement e - | nameLocalName name == DT.pack "message" = XEMessage $ parseMessage $ eventsToElement e - | otherwise = XEOther "TODO: Element instead of String" -- Just (eventsToElement e) - where - (EventBeginElement name attribs) = head e - es = tail e - -eventsToElement :: [Event] -> Element -eventsToElement e = do - documentRoot $ fromJust (run_ $ enum e $$ fromEvents) + True -> loop c (Continue k) + False -> k (Chunks $ DBL.toChunks d) >>== loop c + loop _ step = returnI step + + +-- Consumes XML events from the input stream, accumulating as necessary, and +-- sends the proper events through the channel. The second parameter should be +-- initialized to [] (no events) and the third to 0 (zeroth XML level). + +eventConsumer :: Chan (InternalEvent s m) -> [Event] -> Int -> + Iteratee Event IO (Maybe Event) + +-- open event received. + +eventConsumer chan [EventBeginElement (Name localName namespace prefixName) attribs] 0 + | localName == DT.pack "stream" && isJust prefixName && fromJust prefixName == DT.pack "stream" = do + liftIO $ writeChan chan $ IEE $ EnumeratorBeginStream from to id ver lang ns + eventConsumer chan [] 1 where - enum :: [Event] -> E.Enumerator Event Maybe Document - enum e_ (E.Continue k) = k $ E.Chunks e_ - enum e_ step = E.returnI step + from = case lookup "from" attribs of Nothing -> Nothing; Just fromAttrib -> Just $ show fromAttrib + to = case lookup "to" attribs of Nothing -> Nothing; Just toAttrib -> Just $ show toAttrib + id = case lookup "id" attribs of Nothing -> Nothing; Just idAttrib -> Just $ show idAttrib + ver = case lookup "version" attribs of Nothing -> Nothing; Just verAttrib -> Just $ show verAttrib + lang = case lookup "xml:lang" attribs of Nothing -> Nothing; Just langAttrib -> Just $ show langAttrib + ns = case namespace of Nothing -> Nothing; Just namespaceAttrib -> Just $ DT.unpack namespaceAttrib + +-- close event received. + +eventConsumer chan [EventEndElement name] 1 + | namePrefix name == Just (DT.pack "stream") && nameLocalName name == DT.pack "stream" = do + liftIO $ writeChan chan $ IEE $ EnumeratorEndStream + return Nothing + +-- Ignore EventDocumentBegin event. -counter :: Int -> Maybe Event -> Int -counter c (Just (EventBeginElement _ _)) = (c + 1) -counter c (Just (EventEndElement _) ) = (c - 1) -counter c _ = c +eventConsumer chan [EventBeginDocument] 0 = eventConsumer chan [] 0 + +-- We have received a complete first-level XML element. Process the accumulated +-- values into an first-level element event. + +eventConsumer chan ((EventEndElement e):es) 1 = do + liftIO $ writeChan chan $ IEE $ EnumeratorFirstLevelElement $ eventsToElement $ reverse ((EventEndElement e):es) + eventConsumer chan [] 1 + +-- Normal condition - accumulate the event. + +eventConsumer chan events level = do + event <- DEL.head + case event of + Just event' -> let level' = case event' of + EventBeginElement _ _ -> level + 1 + EventEndElement _ -> level - 1 + _ -> level + in eventConsumer chan (event':events) level' + Nothing -> eventConsumer chan events level + + +eventsToElement :: [Event] -> Either SomeException Element + +eventsToElement e = do + r <- run $ eventsEnum $$ fromEvents + case r of Right doc -> Right $ documentRoot doc; Left ex -> Left ex + where + -- TODO: Type? + eventsEnum (Continue k) = k $ Chunks e + eventsEnum step = returnI step -- Sending stanzas is done through functions, where LangTag is Maybe. @@ -324,10 +311,9 @@ iqToXML (Right (Left i)) streamLang = Element "iq" attribs nodes attribs = stanzaAttribs (iqErrorID i) (iqErrorFrom i) (iqErrorTo i) stanzaLang ++ typeAttrib - -- Has the error element stanza as its child. - -- TODO: Include sender XML here? + -- Has an optional elements as child. nodes :: [Node] - nodes = [NodeElement $ errorElem streamLang stanzaLang $ iqErrorStanzaError i] + nodes = case iqErrorPayload i of Nothing -> []; Just payloadElem -> [NodeElement payloadElem] stanzaLang :: Maybe LangTag stanzaLang = stanzaLang' streamLang $ iqErrorLangTag i diff --git a/Network/XMPP/Types.hs b/Network/XMPP/Types.hs index 132cbff..b656333 100644 --- a/Network/XMPP/Types.hs +++ b/Network/XMPP/Types.hs @@ -34,7 +34,6 @@ Domainpart, Resourcepart, LangTag (..), InternalEvent (..), -XMLEvent (..), ConnectionState (..), ClientEvent (..), StreamState (..), @@ -81,6 +80,7 @@ import Data.Certificate.X509 (X509) import Data.List (intersperse) import Data.Char (toLower) +import Control.Exception.Base (SomeException) -- ============================================================================= -- STANZA TYPES @@ -432,14 +432,10 @@ type Resource = String -- An XMLEvent is triggered by an XML stanza or some other XML event, and is -- sent through the internal event channel, just like client action events. -data XMLEvent = XEBeginStream String | XEFeatures String | - XEChallenge Challenge | XESuccess Success | - XEEndStream | XEIQ IQ | XEPresence InternalPresence | - XEMessage InternalMessage | XEProceed | - XEOther String deriving (Show) - data EnumeratorEvent = EnumeratorDone | - EnumeratorXML XMLEvent | + EnumeratorBeginStream (Maybe String) (Maybe String) (Maybe String) (Maybe String) (Maybe String) (Maybe String) | + EnumeratorEndStream | + EnumeratorFirstLevelElement (Either SomeException Element) | EnumeratorException CE.SomeException deriving (Show)