rewrote xmlReader (now eventConsumer), its depending functions and some enumeration-related types

Network/XMPP/Session.hs

@@ -465,93 +465,93 @@ processEvent e = get >>= \ state ->
     lift $ liftIO $ send ("<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='SCRAM-SHA-1'>" ++ (CBBS.encode ("n,,n=" ++ userName ++ ",r=" ++ (toString rValue))) ++ "</auth>") 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
+--  IEE (EnumeratorXML (XEFeatures features)) -> do
-    let PreFeatures streamProperties = stateStreamState state
+--    let PreFeatures streamProperties = stateStreamState state
-    case stateTLSState state of
+--    case stateTLSState state of
-      NoTLS -> let callback = fromJust $ stateOpenStreamsCallback state in do
+--      NoTLS -> let callback = fromJust $ stateOpenStreamsCallback state in do
-        ((), clientState) <- lift $ runStateT (callback $ OpenStreamSuccess streamProperties "TODO") (stateClientState state)
+--        ((), clientState) <- lift $ runStateT (callback $ OpenStreamSuccess streamProperties "TODO") (stateClientState state)
-        put $ state { stateClientState = clientState
+--        put $ state { stateClientState = clientState
-                    , stateStreamState = PostFeatures streamProperties "TODO" }
+--                    , stateStreamState = PostFeatures streamProperties "TODO" }
-        return Nothing
+--        return Nothing
-      _ -> case stateAuthenticationState state of
+--      _ -> case stateAuthenticationState state of
-        AuthenticatedUnbound _ resource -> do -- TODO: resource
+--        AuthenticatedUnbound _ resource -> do -- TODO: resource
-          case resource of
+--          case resource of
-            Nothing -> do
+--            Nothing -> do
-              lift $ liftIO $ send ("<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:param" ++ "s:xml:ns:xmpp-bind\"></bind></iq>") handleOrTLSCtx
+--              lift $ liftIO $ send ("<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:param" ++ "s:xml:ns:xmpp-bind\"></bind></iq>") handleOrTLSCtx
-              return ()
+--              return ()
-            _ -> do
+--            _ -> do
-              lift $ liftIO $ send ("<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:param" ++ "s:xml:ns:xmpp-bind\"><resource>" ++ fromJust resource ++ "</resource></bind></iq>") handleOrTLSCtx
+--              lift $ liftIO $ send ("<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:param" ++ "s:xml:ns:xmpp-bind\"><resource>" ++ fromJust resource ++ "</resource></bind></iq>") handleOrTLSCtx
-              return ()
+--              return ()
-          id <- liftIO $ nextID $ stateIDGenerator state
+--          id <- liftIO $ nextID $ stateIDGenerator state
-          lift $ liftIO $ send ("<iq type=\"set\" id=\"" ++ id ++ "\"><session xmlns=\"urn:ietf:params:xml:ns:xmpp-session\"/>" ++ "</iq>") handleOrTLSCtx
+--          lift $ liftIO $ send ("<iq type=\"set\" id=\"" ++ id ++ "\"><session xmlns=\"urn:ietf:params:xml:ns:xmpp-session\"/>" ++ "</iq>") handleOrTLSCtx
-
+--
-          -- TODO: Execute callback on iq result
+--          -- TODO: Execute callback on iq result
-
+--
-          let callback = fromJust $ stateAuthenticateCallback state in do -- TODO: streamProperties "TODO" after success
+--          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
+--            ((), clientState) <- lift $ runStateT (callback $ AuthenticateSuccess streamProperties "TODO" "todo") (stateClientState state) -- get proper resource value when moving to iq result
-            put $ state { stateClientState = clientState
+--            put $ state { stateClientState = clientState
-                        , stateStreamState = PostFeatures streamProperties "TODO" }
+--                        , stateStreamState = PostFeatures streamProperties "TODO" }
-          state' <- get
+--          state' <- get
-          return Nothing
+--          return Nothing
-        _ -> do
+--        _ -> do
-          let callback = fromJust $ stateTLSSecureStreamsCallback state in do
+--          let callback = fromJust $ stateTLSSecureStreamsCallback state in do
-          ((), clientState) <- lift $ runStateT (callback $ SecureWithTLSSuccess streamProperties "TODO") (stateClientState state)
+--          ((), clientState) <- lift $ runStateT (callback $ SecureWithTLSSuccess streamProperties "TODO") (stateClientState state)
-          put $ state { stateClientState = clientState
+--          put $ state { stateClientState = clientState
-                      , stateStreamState = PostFeatures streamProperties "TODO" }
+--                      , stateStreamState = PostFeatures streamProperties "TODO" }
-          return Nothing
+--          return Nothing
-
+--
-  -- TODO: Can we assume that it's safe to start to enumerate on handle when it
+--  -- TODO: Can we assume that it's safe to start to enumerate on handle when it
-  -- might not have exited?
+--  -- might not have exited?
-  IEE (EnumeratorXML XEProceed) -> do
+--  IEE (EnumeratorXML XEProceed) -> do
-    let Connected (ServerAddress hostName _) handle = stateConnectionState state
+--    let Connected (ServerAddress hostName _) handle = stateConnectionState state
-    tlsCtx <- lift $ liftIO $ do
+--    tlsCtx <- lift $ liftIO $ do
-        gen <- newGenIO :: IO SystemRandom -- TODO: Investigate limitations
+--        gen <- newGenIO :: IO SystemRandom -- TODO: Investigate limitations
-        clientContext <- client tlsParams gen handle
+--        clientContext <- client tlsParams gen handle
-        handshake clientContext
+--        handshake clientContext
-        return clientContext
+--        return clientContext
-    put $ (defaultState (stateChannel state) (stateThreadID state) (stateClientHandlers state) (stateClientState state) (stateIDGenerator state)) { stateTLSState = PostHandshake tlsCtx, stateConnectionState = (stateConnectionState state), stateTLSSecureStreamsCallback = (stateTLSSecureStreamsCallback state) }
+--    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
+--    threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Right tlsCtx) -- double code
-    lift $ liftIO $ putStrLn "00000000000000000000000000000000"
+--    lift $ liftIO $ putStrLn "00000000000000000000000000000000"
-    lift $ liftIO $ swapMVar (stateThreadID state) threadID -- return value not used
+--    lift $ liftIO $ swapMVar (stateThreadID state) threadID -- return value not used
-    lift $ liftIO $ putStrLn "00000000000000000000000000000000"
+--    lift $ liftIO $ putStrLn "00000000000000000000000000000000"
-    lift $ liftIO $ threadDelay 1000000
+--    lift $ liftIO $ threadDelay 1000000
-    lift $ liftIO $ putStrLn "00000000000000000000000000000000"
+--    lift $ liftIO $ putStrLn "00000000000000000000000000000000"
-    lift $ liftIO $ send ("<?xml version='1.0'?><stream:stream to='" ++
+--    lift $ liftIO $ send ("<?xml version='1.0'?><stream:stream to='" ++
-      hostName ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++
+--      hostName ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++
-      "streams' version='1.0'>") (Right tlsCtx)
+--      "streams' version='1.0'>") (Right tlsCtx)
-    lift $ liftIO $ putStrLn "00000000000000000000000000000000"
+--    lift $ liftIO $ putStrLn "00000000000000000000000000000000"
-    return Nothing
+--    return Nothing
-
+--
-  IEE (EnumeratorXML (XEChallenge (Chal challenge))) -> do
+--  IEE (EnumeratorXML (XEChallenge (Chal challenge))) -> do
-    lift $ liftIO $ putStrLn challenge
+--    lift $ liftIO $ putStrLn challenge
-    let Connected (ServerAddress hostName _) _ = stateConnectionState state
+--    let Connected (ServerAddress hostName _) _ = stateConnectionState state
-    let challenge' = CBBS.decode challenge
+--    let challenge' = CBBS.decode challenge
-    case stateAuthenticationState state of
+--    case stateAuthenticationState state of
-      AuthenticatingPreChallenge1 userName password resource -> do
+--      AuthenticatingPreChallenge1 userName password resource -> do
-        id <- liftIO $ nextID $ stateIDGenerator state
+--        id <- liftIO $ nextID $ stateIDGenerator state
-        -- TODO: replyToChallenge
+--        -- TODO: replyToChallenge
-        return ()
+--        return ()
-      AuthenticatingPreChallenge2 userName password resource -> do
+--      AuthenticatingPreChallenge2 userName password resource -> do
-        -- This is not the first challenge; [...]
+--        -- This is not the first challenge; [...]
-        -- TODO: Can we assume "rspauth"?
+--        -- TODO: Can we assume "rspauth"?
-        lift $ liftIO $ send "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/>" handleOrTLSCtx
+--        lift $ liftIO $ send "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/>" handleOrTLSCtx
-        put $ state { stateAuthenticationState = AuthenticatingPreSuccess userName password resource }
+--        put $ state { stateAuthenticationState = AuthenticatingPreSuccess userName password resource }
-        return ()
+--        return ()
-    return Nothing
+--    return Nothing
-
+--
-  -- We have received a SASL "success" message over a secured connection
+--  -- We have received a SASL "success" message over a secured connection
-  -- TODO: Parse the success message?
+--  -- TODO: Parse the success message?
-  -- TODO: <?xml version='1.0'?>?
+--  -- TODO: <?xml version='1.0'?>?
-  IEE (EnumeratorXML (XESuccess (Succ _))) -> do
+--  IEE (EnumeratorXML (XESuccess (Succ _))) -> do
-    let serverHost = "jonkristensen.com"
+--    let serverHost = "jonkristensen.com"
-    let AuthenticatingPreSuccess userName _ resource = stateAuthenticationState state in do
+--    let AuthenticatingPreSuccess userName _ resource = stateAuthenticationState state in do
-      lift $ liftIO $ send ("<?xml version='1.0'?><stream:stream to='" ++ serverHost ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++ "streams' version='1.0'>") handleOrTLSCtx
+--      lift $ liftIO $ send ("<?xml version='1.0'?><stream:stream to='" ++ serverHost ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++ "streams' version='1.0'>") handleOrTLSCtx
-      put $ state { stateAuthenticationState = AuthenticatedUnbound userName resource }
+--      put $ state { stateAuthenticationState = AuthenticatedUnbound userName resource }
-    return Nothing
+--    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
+--  -- Ignore id="bind_1" and session IQ result, otherwise create client event
-  IEE (EnumeratorXML (XEIQ iqEvent)) ->
+--  IEE (EnumeratorXML (XEIQ iqEvent)) ->
-    case shouldIgnoreIQ iqEvent of
+--    case shouldIgnoreIQ iqEvent of
-        True ->
+--        True ->
-            return Nothing
+--            return Nothing
-        False -> do
+--        False -> do
-            let stanzaID' = iqID iqEvent
+--            let stanzaID' = iqID iqEvent
-            let newTimeouts = case stanzaID' of
+--            let newTimeouts = case stanzaID' of
-                                Just stanzaID'' ->
+--                                Just stanzaID'' ->
-                                    case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of
+--                                    case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of
-                                                True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state)
+--                                                True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state)
-                                                False -> (stateTimeoutStanzaIDs state)
+--                                                False -> (stateTimeoutStanzaIDs state)
-                                Nothing -> (stateTimeoutStanzaIDs state)
+--                                Nothing -> (stateTimeoutStanzaIDs state)
-            let iqReceivedFunctions = map (\ x -> iqReceived x) (stateClientHandlers state)
+--            let iqReceivedFunctions = map (\ x -> iqReceived x) (stateClientHandlers state)
-            let functions = map (\ x -> case x of
+--            let functions = map (\ x -> case x of
-                                    Just f -> Just (f iqEvent)
+--                                    Just f -> Just (f iqEvent)
-                                    Nothing -> Nothing) iqReceivedFunctions
+--                                    Nothing -> Nothing) iqReceivedFunctions
-            let functions' = case lookup (fromJust $ iqID $ iqEvent) (stateIQCallbacks state) of
+--            let functions' = case lookup (fromJust $ iqID $ iqEvent) (stateIQCallbacks state) of
-                                  Just f -> (Just (f $ iqEvent)):functions
+--                                  Just f -> (Just (f $ iqEvent)):functions
-                                  Nothing -> functions
+--                                  Nothing -> functions
-            let clientState = stateClientState state
+--            let clientState = stateClientState state
-            clientState' <- sendToClient functions' clientState
+--            clientState' <- sendToClient functions' clientState
-            put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts }
+--            put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts }
-            return Nothing
+--            return Nothing
-
+--
-  -- TODO: Known bug - does not work with PresenceError
+--  -- TODO: Known bug - does not work with PresenceError
-
+--
-  IEE (EnumeratorXML (XEPresence (Right presenceEvent))) -> do
+--  IEE (EnumeratorXML (XEPresence (Right presenceEvent))) -> do
-    let stanzaID' = presenceID $ presenceEvent
+--    let stanzaID' = presenceID $ presenceEvent
-    let newTimeouts = case stanzaID' of
+--    let newTimeouts = case stanzaID' of
-                        Just stanzaID'' ->
+--                        Just stanzaID'' ->
-                            case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of
+--                            case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of
-                                    True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state)
+--                                    True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state)
-                                    False -> (stateTimeoutStanzaIDs state)
+--                                    False -> (stateTimeoutStanzaIDs state)
-                        Nothing -> (stateTimeoutStanzaIDs state)
+--                        Nothing -> (stateTimeoutStanzaIDs state)
-    let presenceReceivedFunctions = map (\ x -> presenceReceived x) (stateClientHandlers state)
+--    let presenceReceivedFunctions = map (\ x -> presenceReceived x) (stateClientHandlers state)
-    let functions = map (\ x -> case x of
+--    let functions = map (\ x -> case x of
-                            Just f -> Just (f presenceEvent)
+--                            Just f -> Just (f presenceEvent)
-                            Nothing -> Nothing) presenceReceivedFunctions
+--                            Nothing -> Nothing) presenceReceivedFunctions
-    let clientState = stateClientState state -- ClientState s m
+--    let clientState = stateClientState state -- ClientState s m
-    clientState' <- sendToClient functions clientState
+--    clientState' <- sendToClient functions clientState
-    put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts }
+--    put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts }
-    return Nothing
+--    return Nothing
-
+--
-  -- TODO: Does not work with message errors
+--  -- TODO: Does not work with message errors
-  IEE (EnumeratorXML (XEMessage (Right messageEvent))) -> do
+--  IEE (EnumeratorXML (XEMessage (Right messageEvent))) -> do
-    let stanzaID' = messageID $ messageEvent
+--    let stanzaID' = messageID $ messageEvent
-    let newTimeouts = case stanzaID' of
+--    let newTimeouts = case stanzaID' of
-                        Just stanzaID'' ->
+--                        Just stanzaID'' ->
-                            case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of
+--                            case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of
-                                    True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state)
+--                                    True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state)
-                                    False -> (stateTimeoutStanzaIDs state)
+--                                    False -> (stateTimeoutStanzaIDs state)
-                        Nothing -> (stateTimeoutStanzaIDs state)
+--                        Nothing -> (stateTimeoutStanzaIDs state)
-    let messageReceivedFunctions = map (\ x -> messageReceived x) (stateClientHandlers state)
+--    let messageReceivedFunctions = map (\ x -> messageReceived x) (stateClientHandlers state)
-    let functions = map (\ x -> case x of
+--    let functions = map (\ x -> case x of
-                            Just f -> Just (f messageEvent)
+--                            Just f -> Just (f messageEvent)
-                            Nothing -> Nothing) messageReceivedFunctions
+--                            Nothing -> Nothing) messageReceivedFunctions
-    let clientState = stateClientState state -- ClientState s m
+--    let clientState = stateClientState state -- ClientState s m
-    clientState' <- sendToClient functions clientState
+--    clientState' <- sendToClient functions clientState
-    put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts }
+--    put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts }
-    return Nothing
+--    return Nothing
 
   IEC (CEPresence presence stanzaCallback timeoutCallback streamErrorCallback) -> do
     presence' <- case presenceID $ presence of

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 :: TLSCtx -> Step DB.ByteString IO b -> Iteratee DB.ByteString IO b
-    loop c (E.Continue k) = do
+    loop c (Continue k) = do
       d <- recvData c
       case DBL.null d of
-        True  -> loop c (E.Continue k)
+        True  -> loop c (Continue k)
-        False -> k (E.Chunks $ DBL.toChunks d) E.>>== loop c
+        False -> k (Chunks $ DBL.toChunks d) >>== loop c
-    loop _ step = E.returnI step
+    loop _ step = returnI step
-
+
-
+
-xmlReader :: Chan (InternalEvent s m) -> Iteratee Event IO (Maybe Event)
+-- Consumes XML events from the input stream, accumulating as necessary, and
-
+-- sends the proper events through the channel. The second parameter should be
-xmlReader c = xmlReader_ c [] 0
+-- initialized to [] (no events) and the third to 0 (zeroth XML level).
-
+
-
+eventConsumer :: Chan (InternalEvent s m) -> [Event] -> Int ->
-xmlReader_ :: Chan (InternalEvent s m) -> [Event] -> Int ->
+                 Iteratee Event IO (Maybe Event)
-             Iteratee Event IO (Maybe Event)
+
-
+-- <stream:stream> open event received.
-xmlReader_ ch [EventBeginDocument] 0 = xmlReader_ ch [] 0
+
-
+eventConsumer chan [EventBeginElement (Name localName namespace prefixName) attribs] 0
--- TODO: Safe to start change level here? We are doing this since the stream can
+    | localName == DT.pack "stream" && isJust prefixName && fromJust prefixName == DT.pack "stream" = do
--- restart.
+        liftIO $ writeChan chan $ IEE $ EnumeratorBeginStream from to id ver lang ns
--- TODO: l < 2?
+        eventConsumer chan [] 1
-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)
     where
-      enum :: [Event] -> E.Enumerator Event Maybe Document
+        from = case lookup "from" attribs of Nothing -> Nothing; Just fromAttrib -> Just $ show fromAttrib
-      enum e_ (E.Continue k) = k $ E.Chunks e_
+        to = case lookup "to" attribs of Nothing -> Nothing; Just toAttrib -> Just $ show toAttrib
-      enum e_ step = E.returnI step
+        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
+
+-- <stream:stream> 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
+eventConsumer chan [EventBeginDocument] 0 = eventConsumer chan [] 0
-counter c (Just (EventBeginElement _ _)) = (c + 1)
+
-counter c (Just (EventEndElement _) )    = (c - 1)
+-- We have received a complete first-level XML element. Process the accumulated
-counter c _                       = c
+-- 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.
+        -- Has an optional elements as child.
-        -- TODO: Include sender XML here?
         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

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)