From 9f96c71145cea8a8435245d47efe3312cbd8da1e Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Tue, 3 Apr 2012 13:35:30 +0200 Subject: [PATCH] started using xml-conduit instead of xml-enumerator, but because of what seems to be a bug in parseBytes we can't actually read anything --- Network/XMPP/Session.hs | 71 ++++------------- Network/XMPP/Stream.hs | 164 ++++++++++++++++++++++------------------ Network/XMPP/Types.hs | 75 +++++++++++++++--- pontarius.cabal | 6 +- 4 files changed, 171 insertions(+), 145 deletions(-) diff --git a/Network/XMPP/Session.hs b/Network/XMPP/Session.hs index 84b38e1..77e8c67 100644 --- a/Network/XMPP/Session.hs +++ b/Network/XMPP/Session.hs @@ -8,9 +8,7 @@ {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StandaloneDeriving #-} module Network.XMPP.Session ( @@ -23,11 +21,11 @@ module Network.XMPP.Session ( , DisconnectReason ) where - +import Network.XMPP.Stream import Network.XMPP.Types import Network.XMPP.Utilities -import Control.Concurrent (Chan, newChan, readChan, writeChan) +import Control.Concurrent (Chan, forkIO, forkOS, newChan, readChan, writeChan) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Certificate.X509 (X509) import Data.Dynamic (Dynamic) @@ -42,19 +40,6 @@ import Codec.Binary.UTF8.String --- | --- The XMPP monad transformer. Contains internal state in order to --- work with Pontarius. Pontarius clients needs to operate in this --- context. - -newtype XMPPT m a = XMPPT { runXMPPT :: StateT (State m) m a } deriving (Monad, MonadIO) - - --- Make XMPPT derive the Monad and MonadIO instances. - -deriving instance (Monad m, MonadIO m) => MonadState (State m) (XMPPT m) - - create :: MonadIO m => XMPPT m () -> m () create main = do @@ -68,31 +53,10 @@ create main = do stateLoop -data HookId = HookId String deriving (Eq) - - --- We need a channel because multiple threads needs to append events, --- and we need to wait for events when there are none. - -data State m = State { evtChan :: Chan (InternalEvent m) - , hookIdGenerator :: IdGenerator - , hooks :: [Hook m] } - - -data HookPayload m = StreamsOpenedHook (Maybe (Maybe OpenStreamsFailureReason -> XMPPT m Bool)) (Maybe OpenStreamsFailureReason -> XMPPT m Bool) - -type Hook m = (HookId, HookPayload m) - - -- Internal events - events to be processed within Pontarius. -- data InternalEvent s m = IEC (ClientEvent s m) | IEE EnumeratorEvent | IET (TimeoutEvent s m) deriving (Show) -data InternalEvent m - = OpenStreamsEvent HostName PortNumber - -- | DisconnectEvent - | RegisterStreamsOpenedHook (Maybe (Maybe OpenStreamsFailureReason -> XMPPT m Bool)) (Maybe OpenStreamsFailureReason -> XMPPT m Bool) - -- | IEEE EnumeratorEvent instance Show (InternalEvent m) where show _ = "InternalEvent" @@ -121,17 +85,6 @@ data Event = -- ConnectedEvent (Either IntFailureReason Resource) -- | CAFR AuthenticateFailureReason --- TODO: Possible ways opening a stream can fail. -data OpenStreamsFailureReason = OpenStreamsFailureReason deriving (Show) - --- data TLSSecureFailureReason = TLSSecureFailureReason - --- data AuthenticateFailureReason = AuthenticateFailureReason - -data DisconnectReason = DisconnectReason deriving (Show) - - - -- The "hook modification" events have a higher priority than other events, and -- are thus sent through a Chan of their own. The boolean returns value signals -- whether or not the hook should be removed. @@ -153,30 +106,34 @@ stateLoop = do rs <- get event <- liftIO $ readChan $ evtChan rs liftIO $ putStrLn $ "Processing " ++ (show event) ++ "..." - actions <- processEvent event - sequence actions + processEvent event + -- sequence_ IO actions frmo procesEvent? stateLoop -- Processes an internal event and generates a list of impure actions. -processEvent :: MonadIO m => InternalEvent m -> XMPPT m [XMPPT m ()] +processEvent :: MonadIO m => InternalEvent m -> XMPPT m () -processEvent (OpenStreamsEvent h p) = return [openStreamAction h p] +processEvent (OpenStreamsEvent h p) = openStreamAction h p where openStreamAction :: MonadIO m => HostName -> PortNumber -> XMPPT m () openStreamAction h p = let p' = fromIntegral p - computation = do + computation chan = do -- chan ugly + -- threadID <- handle <- N.connectTo h (N.PortNumber p') hSetBuffering handle NoBuffering - hPutStr handle $ encodeString "" + forkIO $ conduit chan (Left handle) -- This must be done after hSetBuffering + hPutStr handle $ encodeString "" -- didn't work with hFlush handle + return () in do - result <- liftIO $ CE.try computation + rs <- get + result <- liftIO $ CE.try (computation $ evtChan rs) case result of Right () -> do fireStreamsOpenedEvent Nothing - -- -- threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Left handle) + return () -- -- lift $ liftIO $ putMVar (stateThreadID state) threadID Left (CE.SomeException e) -> do -- TODO: Safe to do this? fireStreamsOpenedEvent $ Just OpenStreamsFailureReason diff --git a/Network/XMPP/Stream.hs b/Network/XMPP/Stream.hs index feb6a02..7586646 100644 --- a/Network/XMPP/Stream.hs +++ b/Network/XMPP/Stream.hs @@ -6,7 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} module Network.XMPP.Stream ( --- xmlEnumerator, +conduit, presenceToXML, iqToXML, messageToXML, @@ -26,8 +26,8 @@ import Control.Concurrent.Chan (Chan, writeChan) import Control.Exception.Base (SomeException) import Control.Monad.IO.Class (liftIO) import Data.ByteString.Lazy (null, toChunks) -import Data.Enumerator ((>>==), ($$), Iteratee (..), Enumeratee, Step (..), Enumerator (..), Stream (Chunks), returnI, joinI, run) -import Data.Enumerator.Binary (enumHandle) +import Data.Conduit (($$), ($=), MonadResource, Sink (..), runResourceT) +import Data.Conduit.Binary (sourceHandle) import Data.Maybe (fromJust, isJust) import Data.Text (pack, unpack) 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.ByteString (GenParser) -- import Text.XML.Enumerator.Document (fromEvents) --- import Text.XML.Enumerator.Parse (parseBytes, decodeEntities) - -import qualified Data.ByteString as DB (ByteString) -import qualified Data.ByteString.Char8 as DBC (pack) -import qualified Data.Enumerator.List as DEL (head) +import Text.XML.Stream.Parse (def, parseBytes) +import Text.XML.Unresolved (fromEvents) +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 - --- xmlEnumerator c s = do --- enumeratorResult <- case s of --- Left handle -> run $ enumHandle 1 handle $$ joinI $ --- parseBytes decodeEntities $$ eventConsumer c [] 0 --- Right tlsCtx -> run $ enumTLS tlsCtx $$ joinI $ --- parseBytes decodeEntities $$ eventConsumer c [] 0 --- case enumeratorResult of --- Right _ -> return () -- writeChan c $ IEE EnumeratorDone --- Left e -> return () -- writeChan c $ IEE (EnumeratorException e) +import qualified Data.ByteString as DB (ByteString) +import qualified Data.ByteString.Char8 as DBC (pack) +import qualified Data.Conduit.List as DEL (head) +import Data.Conduit.List (consume, sourceList) -- use lazy consume instead? + + +-- Reads from the provided handle or TLS context and sends the events +-- to the internal event channel. + +conduit :: MonadIO m => Chan (InternalEvent m) -> Either Handle (TLSCtx a) -> IO () + +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 --- -- Behaves like enumHandle, but reads from the TLS context instead --- -- TODO: Type? --- enumTLS :: TLSCtx -> Enumerator DB.ByteString IO b --- enumTLS c s = loop c s --- --- -- TODO: Type? --- loop :: TLSCtx -> Step DB.ByteString IO b -> Iteratee DB.ByteString IO b --- loop c (Continue k) = do --- d <- recvData c --- case null d of --- True -> loop c (Continue k) --- False -> k (Chunks $ toChunks d) >>== loop c +-- -- Behaves like enumHandle, but reads from the TLS context instead +-- -- TODO: Type? +-- enumTLS :: TLSCtx -> Enumerator DB.ByteString IO b +-- enumTLS c s = loop c s + +-- -- TODO: Type? +-- loop :: TLSCtx -> Step DB.ByteString IO b -> Iteratee DB.ByteString IO b +-- loop c (Continue k) = do +-- d <- recvData c +-- case null d of +-- True -> loop c (Continue k) +-- False -> k (Chunks $ 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). +-- 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 -> [Event] -> Int -> --- Iteratee Event IO (Maybe Event) -- Was: InternalEvent s m +eventConsumer :: (MonadResource r, MonadIO m) => + Chan (InternalEvent m) -> [Event] -> Int -> Sink Event r () -- open event received. --- eventConsumer chan [EventBeginElement (Name localName namespace prefixName) attribs] 0 --- | localName == pack "stream" && isJust prefixName && fromJust prefixName == pack "stream" = do --- liftIO $ return () -- writeChan chan $ IEE $ EnumeratorBeginStream from to id ver lang ns --- eventConsumer chan [] 1 --- where --- 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 $ unpack namespaceAttrib +eventConsumer chan [EventBeginElement (Name localName namespace prefixName) attribs] 0 + | localName == pack "stream" && isJust prefixName && fromJust prefixName == pack "stream" = do + liftIO $ putStrLn "here?" + liftIO $ writeChan chan $ EnumeratorBeginStream from to id ver lang ns + eventConsumer chan [] 1 + where + 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 $ unpack namespaceAttrib -- close event received. --- eventConsumer chan [EventEndElement name] 1 --- | namePrefix name == Just (pack "stream") && nameLocalName name == pack "stream" = do --- liftIO $ return () -- writeChan chan $ IEE $ EnumeratorEndStream --- return Nothing +eventConsumer chan [EventEndElement name] 1 + | namePrefix name == Just (pack "stream") && nameLocalName name == pack "stream" = do + liftIO $ putStrLn "here!" + liftIO $ writeChan chan $ EnumeratorEndStream + return () -- Ignore EventDocumentBegin event. --- eventConsumer chan [EventBeginDocument] 0 = eventConsumer chan [] 0 +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 $ return () -- writeChan chan $ IEE $ EnumeratorFirstLevelElement $ eventsToElement $ reverse ((EventEndElement e):es) --- eventConsumer chan [] 1 +eventConsumer chan ((EventEndElement e):es) 1 = do + liftIO $ putStrLn "here..." + element <- liftIO $ eventsToElement $ reverse ((EventEndElement e):es) + liftIO $ writeChan chan $ EnumeratorFirstLevelElement element + 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 +eventConsumer chan events level = do + liftIO $ putStrLn "listenering for XML event" + event <- DEL.head + liftIO $ putStrLn "got event" + 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] -> IO Element -- Was: Either SomeException Element --- eventsToElement :: [Event] -> Either SomeException Element +-- TODO: Exceptions. --- eventsToElement e = do --- r <- run $ eventsEnum $$ fromEvents --- case r of Right doc -> Right $ documentRoot doc; Left ex -> Left ex +eventsToElement e = do + putStrLn "eventsToElement" + doc <- runResourceT $ sourceList e $$ fromEvents + return $ documentRoot doc +-- 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 +-- -- TODO: Type? +-- eventsEnum (Continue k) = k $ Chunks e +-- eventsEnum step = returnI step -- Sending stanzas is done through functions, where LangTag is Maybe. diff --git a/Network/XMPP/Types.hs b/Network/XMPP/Types.hs index bee73ed..0a90287 100644 --- a/Network/XMPP/Types.hs +++ b/Network/XMPP/Types.hs @@ -4,6 +4,9 @@ {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} + module Network.XMPP.Types ( StanzaID (..), @@ -24,9 +27,9 @@ StanzaErrorCondition (..), , PortNumber , Resource , UserName, -EnumeratorEvent (..), Challenge (..), Success (..), +InternalEvent (..), -- TLSState (..), Address (..), Localpart, @@ -35,6 +38,9 @@ Resourcepart, LangTag (..), ConnectionState (..), ClientEvent (..), +XMPPT (..), +OpenStreamsFailureReason (..), +DisconnectReason (..), StreamState (..), AuthenticationState (..), ConnectResult (..), @@ -55,6 +61,10 @@ PresenceError (..), InternalPresence (..), InternalMessage (..), MessageError (..), +HookId (..), +Hook (..), +HookPayload (..), +State (..) ) where import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput) @@ -81,6 +91,8 @@ import Data.Char (toLower) import Control.Exception.Base (SomeException) +import Control.Concurrent + -- ============================================================================= -- STANZA TYPES -- ============================================================================= @@ -136,6 +148,56 @@ data IQRequest = IQRequest { iqRequestID :: Maybe StanzaID deriving (Show) +data InternalEvent m + = OpenStreamsEvent HostName PortNumber + -- | DisconnectEvent + | RegisterStreamsOpenedHook (Maybe (Maybe OpenStreamsFailureReason -> XMPPT m Bool)) (Maybe OpenStreamsFailureReason -> XMPPT m Bool) + | EnumeratorFirstLevelElement Element + -- | IEEE EnumeratorEvent + | EnumeratorDone + | EnumeratorBeginStream (Maybe String) (Maybe String) (Maybe String) (Maybe String) (Maybe String) (Maybe String) + | EnumeratorEndStream + | EnumeratorException CE.SomeException + +-- | +-- The XMPP monad transformer. Contains internal state in order to +-- work with Pontarius. Pontarius clients needs to operate in this +-- context. + +newtype XMPPT m a = XMPPT { runXMPPT :: StateT (State m) m a } deriving (Monad, MonadIO) + + +-- Make XMPPT derive the Monad and MonadIO instances. + +deriving instance (Monad m, MonadIO m) => MonadState (State m) (XMPPT m) + + +-- We need a channel because multiple threads needs to append events, +-- and we need to wait for events when there are none. + +data State m = State { evtChan :: Chan (InternalEvent m) + , hookIdGenerator :: IdGenerator + , hooks :: [Hook m] } + + +data HookId = HookId String deriving (Eq) + +data HookPayload m = StreamsOpenedHook (Maybe (Maybe OpenStreamsFailureReason -> XMPPT m Bool)) (Maybe OpenStreamsFailureReason -> XMPPT m Bool) + +type Hook m = (HookId, HookPayload m) + + +-- TODO: Possible ways opening a stream can fail. +data OpenStreamsFailureReason = OpenStreamsFailureReason deriving (Show) + +-- data TLSSecureFailureReason = TLSSecureFailureReason + +-- data AuthenticateFailureReason = AuthenticateFailureReason + +data DisconnectReason = DisconnectReason deriving (Show) + + + data IQRequestType = Get | Set deriving (Show) @@ -428,17 +490,6 @@ type Password = String 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 EnumeratorEvent = EnumeratorDone | - EnumeratorBeginStream (Maybe String) (Maybe String) (Maybe String) (Maybe String) (Maybe String) (Maybe String) | - EnumeratorEndStream | - EnumeratorFirstLevelElement (Either SomeException Element) | - EnumeratorException CE.SomeException - deriving (Show) - - data TimeoutEvent s m = TimeoutEvent StanzaID Timeout (StateT s m ()) instance Show (TimeoutEvent s m) where diff --git a/pontarius.cabal b/pontarius.cabal index 8eb5dbf..ecc58c4 100644 --- a/pontarius.cabal +++ b/pontarius.cabal @@ -23,12 +23,12 @@ Tested-With: GHC ==7.0.4 Library Exposed: True - Build-Depends: base >= 2 && < 5, parsec, enumerator, crypto-api, base64-string, pureMD5, + Build-Depends: base >= 2 && < 5, parsec, crypto-api, base64-string, pureMD5, utf8-string, network, xml-types, text, transformers, - bytestring, cereal, random, xml-enumerator, + bytestring, cereal, random, tls, tls-extra, containers, mtl, text-icu, stringprep, asn1-data, cryptohash, time, - certificate, ranges, uuid + certificate, ranges, uuid, conduit, xml-conduit -- Other-Modules: -- HS-Source-Dirs: -- Extensions: