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)