@ -6,7 +6,7 @@
{- # LANGUAGE OverloadedStrings # -} {- # LANGUAGE OverloadedStrings # -}
module Network.XMPP.Stream ( module Network.XMPP.Stream (
-- xmlEnumerator ,conduit ,
presenceToXML , presenceToXML ,
iqToXML , iqToXML ,
messageToXML , messageToXML ,
@ -26,8 +26,8 @@ import Control.Concurrent.Chan (Chan, writeChan)
import Control.Exception.Base ( SomeException ) import Control.Exception.Base ( SomeException )
import Control.Monad.IO.Class ( liftIO ) import Control.Monad.IO.Class ( liftIO )
import Data.ByteString.Lazy ( null , toChunks ) import Data.ByteString.Lazy ( null , toChunks )
import Data.Enumerator ( ( >>== ) , ( $$ ) , Iteratee ( .. ) , Enumeratee , Step ( .. ) , Enumerator ( .. ) , Stream ( Chunks ) , returnI , joinI , run ) import Data.Conduit ( ( $$ ) , ( $= ) , MonadResource , Sink ( .. ) , runResourceT )
import Data.Enumerator.Binary ( enum Handle ) import Data.Conduit.Binary ( source Handle )
import Data.Maybe ( fromJust , isJust ) import Data.Maybe ( fromJust , isJust )
import Data.Text ( pack , unpack ) import Data.Text ( pack , unpack )
import Data.XML.Types ( Content ( .. ) , Document ( .. ) , Element ( .. ) , Event ( .. ) , Name ( .. ) , Node ( .. ) ) import Data.XML.Types ( Content ( .. ) , Document ( .. ) , Element ( .. ) , Event ( .. ) , Name ( .. ) , Node ( .. ) )
@ -36,104 +36,122 @@ import Network.TLS (TLSCtx, recvData)
import Text.Parsec ( char , count , digit , eof , many , many1 , oneOf , parse ) import Text.Parsec ( char , count , digit , eof , many , many1 , oneOf , parse )
import Text.Parsec.ByteString ( GenParser ) import Text.Parsec.ByteString ( GenParser )
-- import Text.XML.Enumerator.Document (fromEvents) -- import Text.XML.Enumerator.Document (fromEvents)
-- import Text.XML.Enumerator.Parse (parseBytes, decodeEntities) import Text.XML.Stream.Parse ( def , parseBytes )
import Text.XML.Unresolved ( fromEvents )
import qualified Data.ByteString as DB ( ByteString )
import qualified Data.ByteString.Char8 as DBC ( pack )
import qualified Data.Enumerator.List as DEL ( head )
import Control.Monad.IO.Class ( MonadIO , liftIO )
-- Reads from the provided handle or TLS context and sends the events to the
-- internal event channel.
-- xmlEnumerator :: Chan InternalEvent -> Either Handle TLSCtx -> IO () -- Was: InternalEvent s m import qualified Data.ByteString as DB ( ByteString )
import qualified Data.ByteString.Char8 as DBC ( pack )
-- xmlEnumerator c s = do import qualified Data.Conduit.List as DEL ( head )
-- enumeratorResult <- case s of import Data.Conduit.List ( consume , sourceList ) -- use lazy consume instead?
-- Left handle -> run $ enumHandle 1 handle $$ joinI $
-- parseBytes decodeEntities $$ eventConsumer c [] 0
-- Right tlsCtx -> run $ enumTLS tlsCtx $$ joinI $ -- Reads from the provided handle or TLS context and sends the events
-- parseBytes decodeEntities $$ eventConsumer c [] 0 -- to the internal event channel.
-- case enumeratorResult of
-- Right _ -> return () -- writeChan c $ IEE EnumeratorDone conduit :: MonadIO m => Chan ( InternalEvent m ) -> Either Handle ( TLSCtx a ) -> IO ()
-- Left e -> return () -- writeChan c $ IEE (EnumeratorException e)
conduit c s = do
enumeratorResult <- case s of
Left handle -> do
print <- runResourceT $ sourceHandle handle $= parseBytes def $$ DEL . head -- $$ DEL.head -- eventConsumer c [] 0
return $ Right 0 -- TODO
Right tlsCtx -> -- run $ enumTLS tlsCtx $$ joinI $
-- parseBytes decodeEntities $$ eventConsumer c [] 0
return $ Left 0 -- TODO
case enumeratorResult of
Right _ -> return () -- writeChan c $ IEE EnumeratorDone
Left e -> return () -- writeChan c $ IEE (EnumeratorException e)
-- where -- where
-- -- Behaves like enumHandle, but reads from the TLS context instead -- -- Behaves like enumHandle, but reads from the TLS context instead
-- -- TODO: Type? -- -- TODO: Type?
-- enumTLS :: TLSCtx -> Enumerator DB.ByteString IO b -- enumTLS :: TLSCtx -> Enumerator DB.ByteString IO b
-- enumTLS c s = loop c s -- enumTLS c s = loop c s
--
-- -- TODO: Type? -- -- TODO: Type?
-- loop :: TLSCtx -> Step DB.ByteString IO b -> Iteratee DB.ByteString IO b -- loop :: TLSCtx -> Step DB.ByteString IO b -> Iteratee DB.ByteString IO b
-- loop c (Continue k) = do -- loop c (Continue k) = do
-- d <- recvData c -- d <- recvData c
-- case null d of -- case null d of
-- True -> loop c (Continue k) -- True -> loop c (Continue k)
-- False -> k (Chunks $ toChunks d) >>== loop c -- False -> k (Chunks $ toChunks d) >>== loop c
-- loop _ step = returnI step -- loop _ step = returnI step
-- Consumes XML events from the input stream, accumulating as necessary, and -- Consumes XML events from the input stream, accumulating as
-- sends the proper events through the channel. The second parameter should be -- necessary, and sends the proper events through the channel. The
-- initialized to [] (no events) and the third to 0 (zeroth XML level). -- second parameter should be initialized to [] (no events) and the
-- third to 0 (zeroth XML level).
-- eventConsumer :: Chan InternalEvent -> [Event] -> Int - >eventConsumer :: ( MonadResource r , MonadIO m ) = >
-- Iteratee Event IO (Maybe Event) -- Was: InternalEvent s m Chan ( InternalEvent m ) -> [ Event ] -> Int -> Sink Event r ()
-- <stream:stream> open event received. -- <stream:stream> open event received.
-- eventConsumer chan [EventBeginElement (Name localName namespace prefixName) attribs] 0 eventConsumer chan [ EventBeginElement ( Name localName namespace prefixName ) attribs ] 0
-- | localName == pack "stream" && isJust prefixName && fromJust prefixName == pack "stream" = do | localName == pack " stream " && isJust prefixName && fromJust prefixName == pack " stream " = do
-- liftIO $ return () -- writeChan chan $ IEE $ EnumeratorBeginStream from to id ver lang ns liftIO $ putStrLn " here? "
-- eventConsumer chan [] 1 liftIO $ writeChan chan $ EnumeratorBeginStream from to id ver lang ns
-- where eventConsumer chan [] 1
-- from = case lookup "from" attribs of Nothing -> Nothing; Just fromAttrib -> Just $ show fromAttrib where
-- to = case lookup "to" attribs of Nothing -> Nothing; Just toAttrib -> Just $ show toAttrib from = case lookup " from " attribs of Nothing -> Nothing ; Just fromAttrib -> Just $ show fromAttrib
-- id = case lookup "id" attribs of Nothing -> Nothing; Just idAttrib -> Just $ show idAttrib to = case lookup " to " attribs of Nothing -> Nothing ; Just toAttrib -> Just $ show toAttrib
-- ver = case lookup "version" attribs of Nothing -> Nothing; Just verAttrib -> Just $ show verAttrib id = case lookup " id " attribs of Nothing -> Nothing ; Just idAttrib -> Just $ show idAttrib
-- lang = case lookup "xml:lang" attribs of Nothing -> Nothing; Just langAttrib -> Just $ show langAttrib ver = case lookup " version " attribs of Nothing -> Nothing ; Just verAttrib -> Just $ show verAttrib
-- ns = case namespace of Nothing -> Nothing; Just namespaceAttrib -> Just $ unpack namespaceAttrib lang = case lookup " xml:lang " attribs of Nothing -> Nothing ; Just langAttrib -> Just $ show langAttrib
ns = case namespace of Nothing -> Nothing ; Just namespaceAttrib -> Just $ unpack namespaceAttrib
-- <stream:stream> close event received. -- <stream:stream> close event received.
-- eventConsumer chan [EventEndElement name] 1 eventConsumer chan [ EventEndElement name ] 1
-- | namePrefix name == Just (pack "stream") && nameLocalName name == pack "stream" = do | namePrefix name == Just ( pack " stream " ) && nameLocalName name == pack " stream " = do
-- liftIO $ return () -- writeChan chan $ IEE $ EnumeratorEndStream liftIO $ putStrLn " here! "
-- return Nothing liftIO $ writeChan chan $ EnumeratorEndStream
return ()
-- Ignore EventDocumentBegin event. -- Ignore EventDocumentBegin event.
-- eventConsumer chan [EventBeginDocument] 0 = eventConsumer chan [] 0eventConsumer chan [ EventBeginDocument ] 0 = eventConsumer chan [] 0
-- We have received a complete first-level XML element. Process the accumulated -- We have received a complete first-level XML element. Process the accumulated
-- values into an first-level element event. -- values into an first-level element event.
-- eventConsumer chan ((EventEndElement e):es) 1 = do eventConsumer chan ( ( EventEndElement e ) : es ) 1 = do
-- liftIO $ return () -- writeChan chan $ IEE $ EnumeratorFirstLevelElement $ eventsToElement $ reverse ((EventEndElement e):es) liftIO $ putStrLn " here... "
-- eventConsumer chan [] 1 element <- liftIO $ eventsToElement $ reverse ( ( EventEndElement e ) : es )
liftIO $ writeChan chan $ EnumeratorFirstLevelElement element
eventConsumer chan [] 1
-- Normal condition - accumulate the event. -- Normal condition - accumulate the event.
-- eventConsumer chan events level = do eventConsumer chan events level = do
-- event <- DEL.head liftIO $ putStrLn " listenering for XML event "
-- case event of event <- DEL . head
-- Just event' -> let level' = case event' of liftIO $ putStrLn " got event "
-- EventBeginElement _ _ -> level + 1 case event of
-- EventEndElement _ -> level - 1 Just event' -> let level' = case event' of
-- _ -> level EventBeginElement _ _ -> level + 1
-- in eventConsumer chan (event':events) level' EventEndElement _ -> level - 1
-- Nothing -> eventConsumer chan events level _ -> level
in eventConsumer chan ( event' : events ) level'
Nothing -> eventConsumer chan events level
eventsToElement :: [ Event ] -> IO Element -- Was: Either SomeException Element
-- eventsToElement :: [Event] -> Either SomeException Element -- TODO: Exceptions.
-- eventsToElement e = do eventsToElement e = do
-- r <- run $ eventsEnum $$ fromEvents putStrLn " eventsToElement "
-- case r of Right doc -> Right $ documentRoot doc; Left ex -> Left ex doc <- runResourceT $ sourceList e $$ fromEvents
return $ documentRoot doc
-- case r of Right doc -> Right $ documentRoot doc; Left ex -> Left ex
-- where -- where
-- -- TODO: Type? -- -- TODO: Type?
-- eventsEnum (Continue k) = k $ Chunks e -- eventsEnum (Continue k) = k $ Chunks e
-- eventsEnum step = returnI step -- eventsEnum step = returnI step
-- Sending stanzas is done through functions, where LangTag is Maybe. -- Sending stanzas is done through functions, where LangTag is Maybe.
Jon Kristensen
14 years ago