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

@@ -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 "<?xml version='1.0'?><stream:stream to='" ++ h ++ "' version='1.0' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams'>"
+                                 forkIO $ conduit chan (Left handle) -- This must be done after hSetBuffering
+                                 hPutStr handle $ encodeString "<stream:stream to='" ++ h ++ "' version='1.0' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams'>" -- didn't work with <?xml version='1.0'>
                                  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

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,33 +36,40 @@ 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 Text.XML.Stream.Parse (def, parseBytes)
+import Text.XML.Unresolved (fromEvents)
+
+import Control.Monad.IO.Class (MonadIO, liftIO)
+
 
 import qualified Data.ByteString as DB (ByteString)
 import qualified Data.ByteString.Char8 as DBC (pack)
-import qualified Data.Enumerator.List as DEL (head)
+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.
+-- 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
+conduit :: MonadIO m => Chan (InternalEvent m) -> Either Handle (TLSCtx a) -> IO ()
 
--- xmlEnumerator c s = do
---     enumeratorResult <- case s of
---         Left handle -> run $ enumHandle 1 handle $$ joinI $
+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
---         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)
+      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
@@ -73,62 +80,73 @@ import qualified Data.Enumerator.List as DEL (head)
 --         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 ()
 
 -- <stream:stream> 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
 
 -- <stream:stream> 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
+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?

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

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: