From 59a7bf89ae1c82e1128467e971c7a8c8b755fba2 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Sun, 17 Feb 2013 21:10:39 +0100 Subject: [PATCH] Clean-up and migration of Text.Xml.Conduit.Elements `ppElements' is only used by Network.Xmpp.Xep.InbandRegistration, so I moved it there for the time-being. As `elements' is only used in Stream.hs, I moved it there. `parseElement' is not used anywhere, and was removed completely. `renderElement' (and its local `elementToEvents' function) is used by Stream.hs and Concurrent.hs, so I moved it to Utilties.hs. (We could argue for a separate `Elements' module, but right now that seems a bit thin. `openElementToEvents' is used by both `elementToEvents' and `renderOpenElement', so I put both `openElementToEvents' and `renderOpenElement' in Utilities.hs as well. `compressNodes' and `streamName' were made where-local to `elements'. The types were moved to Types.hs. --- pontarius-xmpp.cabal | 1 - source/Network/Xmpp/Concurrent.hs | 2 +- source/Network/Xmpp/Stream.hs | 49 +++++++- source/Network/Xmpp/Types.hs | 9 ++ source/Network/Xmpp/Utilities.hs | 49 +++++++- source/Network/Xmpp/Xep/InbandRegistration.hs | 3 + source/Text/Xml/Stream/Elements.hs | 108 ------------------ 7 files changed, 107 insertions(+), 114 deletions(-) delete mode 100644 source/Text/Xml/Stream/Elements.hs diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 97c25ad..cb1f474 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -80,7 +80,6 @@ Library , Network.Xmpp.Tls , Network.Xmpp.Types , Network.Xmpp.Xep.ServiceDiscovery - , Text.Xml.Stream.Elements GHC-Options: -Wall Source-Repository head diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 5c6de2b..b6df58c 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -33,7 +33,6 @@ import Network.Xmpp.Concurrent.Types import Network.Xmpp.Concurrent.Threads import Network.Xmpp.Marshal import Network.Xmpp.Types -import Text.Xml.Stream.Elements import Network import Data.Text as Text import Network.Xmpp.Tls @@ -43,6 +42,7 @@ import Network.Xmpp.Sasl.Mechanisms import Network.Xmpp.Sasl.Types import Data.Maybe import Network.Xmpp.Stream +import Network.Xmpp.Utilities import Control.Monad.Error diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index b44d270..30b0390 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -25,7 +25,6 @@ import Data.XML.Types import Network.Xmpp.Types import Network.Xmpp.Marshal -import Text.Xml.Stream.Elements import Text.XML.Stream.Parse as XP import Control.Concurrent (forkIO, threadDelay) @@ -50,6 +49,9 @@ import Data.ByteString.Char8 as BSC8 import Text.XML.Unresolved(InvalidEventStream(..)) import qualified Control.Exception.Lifted as ExL +import Control.Monad.Trans.Resource as R +import Network.Xmpp.Utilities + -- import Text.XML.Stream.Elements -- Unpickles and returns a stream element. @@ -481,3 +483,48 @@ debugConduit = forever $ do liftIO $ BS.putStrLn (BS.append "in: " s) yield s Nothing -> return () + +elements :: R.MonadThrow m => Conduit Event m Element +elements = do + x <- await + case x of + Just (EventBeginElement n as) -> do + goE n as >>= yield + elements + Just (EventEndElement streamName) -> lift $ R.monadThrow StreamEnd + Nothing -> return () + _ -> lift $ R.monadThrow $ InvalidXmppXml $ "not an element: " ++ show x + where + many' f = + go id + where + go front = do + x <- f + case x of + Left x -> return $ (x, front []) + Right y -> go (front . (:) y) + goE n as = do + (y, ns) <- many' goN + if y == Just (EventEndElement n) + then return $ Element n as $ compressNodes ns + else lift $ R.monadThrow $ InvalidXmppXml $ + "Missing close tag: " ++ show n + goN = do + x <- await + case x of + Just (EventBeginElement n as) -> (Right . NodeElement) <$> goE n as + Just (EventInstruction i) -> return $ Right $ NodeInstruction i + Just (EventContent c) -> return $ Right $ NodeContent c + Just (EventComment t) -> return $ Right $ NodeComment t + Just (EventCDATA t) -> return $ Right $ NodeContent $ ContentText t + _ -> return $ Left x + + compressNodes :: [Node] -> [Node] + compressNodes [] = [] + compressNodes [x] = [x] + compressNodes (NodeContent (ContentText x) : NodeContent (ContentText y) : z) = + compressNodes $ NodeContent (ContentText $ x `Text.append` y) : z + compressNodes (x:xs) = x : compressNodes xs + + streamName :: Name + streamName = (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 5697ac9..c8da297 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -43,6 +43,8 @@ module Network.Xmpp.Types , isBare , isFull , fromString + , StreamEnd(..) + , InvalidXmppXml(..) ) where @@ -1019,3 +1021,10 @@ resourceprepProfile = SP.Profile { SP.maps = [SP.b1] ] , SP.shouldCheckBidi = True } + +data StreamEnd = StreamEnd deriving (Typeable, Show) +instance Exception StreamEnd + +data InvalidXmppXml = InvalidXmppXml String deriving (Show, Typeable) + +instance Exception InvalidXmppXml diff --git a/source/Network/Xmpp/Utilities.hs b/source/Network/Xmpp/Utilities.hs index 3eaa793..8b4864f 100644 --- a/source/Network/Xmpp/Utilities.hs +++ b/source/Network/Xmpp/Utilities.hs @@ -3,7 +3,7 @@ {-# OPTIONS_HADDOCK hide #-} -module Network.Xmpp.Utilities (idGenerator, presTo, message, answerMessage) where +module Network.Xmpp.Utilities (presTo, message, answerMessage, openElementToEvents, renderOpenElement, renderElement) where import Network.Xmpp.Types @@ -16,7 +16,24 @@ import Data.XML.Types import qualified Data.Attoparsec.Text as AP import qualified Data.Text as Text +import qualified Data.ByteString as BS +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import System.IO.Unsafe(unsafePerformIO) +import Data.Conduit.List as CL +-- import Data.Typeable +import Control.Applicative ((<$>)) +import Control.Exception +import Control.Monad.Trans.Class + +import Data.Conduit as C +import Data.XML.Types + +import qualified Text.XML.Stream.Render as TXSR +import Text.XML.Unresolved as TXU + +-- TODO: Not used, and should probably be removed. -- | Creates a new @IdGenerator@. Internally, it will maintain an infinite list -- of IDs ('[\'a\', \'b\', \'c\'...]'). The argument is a prefix to prepend the -- IDs with. Calling the function will extract an ID and update the generator's @@ -39,11 +56,11 @@ idGenerator prefix = atomically $ do -- Generates an infinite and predictable list of IDs, all beginning with the -- provided prefix. Adds the prefix to all combinations of IDs (ids'). ids :: Text.Text -> [Text.Text] - ids p = map (\ id -> Text.append p id) ids' + ids p = Prelude.map (\ id -> Text.append p id) ids' where -- Generate all combinations of IDs, with increasing length. ids' :: [Text.Text] - ids' = map Text.pack $ concatMap ids'' [1..] + ids' = Prelude.map Text.pack $ Prelude.concatMap ids'' [1..] -- Generates all combinations of IDs with the given length. ids'' :: Integer -> [String] ids'' 0 = [""] @@ -81,3 +98,29 @@ answerMessage Message{messageFrom = Just frm, ..} payload = , .. } answerMessage _ _ = Nothing + +openElementToEvents :: Element -> [Event] +openElementToEvents (Element name as ns) = EventBeginElement name as : goN ns [] + where + goE (Element name' as' ns') = + (EventBeginElement name' as' :) + . goN ns' + . (EventEndElement name' :) + goN [] = id + goN [x] = goN' x + goN (x:xs) = goN' x . goN xs + goN' (NodeElement e) = goE e + goN' (NodeInstruction i) = (EventInstruction i :) + goN' (NodeContent c) = (EventContent c :) + goN' (NodeComment t) = (EventComment t :) + +renderOpenElement :: Element -> BS.ByteString +renderOpenElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO + $ CL.sourceList (openElementToEvents e) $$ TXSR.renderText def =$ CL.consume + +renderElement :: Element -> BS.ByteString +renderElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO + $ CL.sourceList (elementToEvents e) $$ TXSR.renderText def =$ CL.consume + where + elementToEvents :: Element -> [Event] + elementToEvents e@(Element name _ _) = openElementToEvents e ++ [EventEndElement name] diff --git a/source/Network/Xmpp/Xep/InbandRegistration.hs b/source/Network/Xmpp/Xep/InbandRegistration.hs index e970310..02925b7 100644 --- a/source/Network/Xmpp/Xep/InbandRegistration.hs +++ b/source/Network/Xmpp/Xep/InbandRegistration.hs @@ -202,3 +202,6 @@ instance Read Field where -- Registered -- Instructions + +ppElement :: Element -> String +ppElement = Text.unpack . Text.decodeUtf8 . renderElement diff --git a/source/Text/Xml/Stream/Elements.hs b/source/Text/Xml/Stream/Elements.hs deleted file mode 100644 index a357607..0000000 --- a/source/Text/Xml/Stream/Elements.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -module Text.Xml.Stream.Elements where - -import Control.Applicative ((<$>)) -import Control.Exception -import Control.Monad.Trans.Class -import Control.Monad.Trans.Resource as R - -import qualified Data.ByteString as BS -import Data.Conduit as C -import Data.Conduit.List as CL -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Data.Typeable -import Data.XML.Types - -import System.IO.Unsafe(unsafePerformIO) - -import qualified Text.XML.Stream.Render as TXSR -import Text.XML.Unresolved as TXU - -compressNodes :: [Node] -> [Node] -compressNodes [] = [] -compressNodes [x] = [x] -compressNodes (NodeContent (ContentText x) : NodeContent (ContentText y) : z) = - compressNodes $ NodeContent (ContentText $ x `Text.append` y) : z -compressNodes (x:xs) = x : compressNodes xs - -streamName :: Name -streamName = - (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) - -data StreamEnd = StreamEnd deriving (Typeable, Show) -instance Exception StreamEnd - -data InvalidXmppXml = InvalidXmppXml String deriving (Show, Typeable) - -instance Exception InvalidXmppXml - -parseElement txt = documentRoot $ TXU.parseText_ TXU.def txt - -elements :: R.MonadThrow m => C.Conduit Event m Element -elements = do - x <- C.await - case x of - Just (EventBeginElement n as) -> do - goE n as >>= C.yield - elements - Just (EventEndElement streamName) -> lift $ R.monadThrow StreamEnd - Nothing -> return () - _ -> lift $ R.monadThrow $ InvalidXmppXml $ "not an element: " ++ show x - where - many' f = - go id - where - go front = do - x <- f - case x of - Left x -> return $ (x, front []) - Right y -> go (front . (:) y) - goE n as = do - (y, ns) <- many' goN - if y == Just (EventEndElement n) - then return $ Element n as $ compressNodes ns - else lift $ R.monadThrow $ InvalidXmppXml $ - "Missing close tag: " ++ show n - goN = do - x <- await - case x of - Just (EventBeginElement n as) -> (Right . NodeElement) <$> goE n as - Just (EventInstruction i) -> return $ Right $ NodeInstruction i - Just (EventContent c) -> return $ Right $ NodeContent c - Just (EventComment t) -> return $ Right $ NodeComment t - Just (EventCDATA t) -> return $ Right $ NodeContent $ ContentText t - _ -> return $ Left x - - -openElementToEvents :: Element -> [Event] -openElementToEvents (Element name as ns) = EventBeginElement name as : goN ns [] - where - goE (Element name' as' ns') = - (EventBeginElement name' as' :) - . goN ns' - . (EventEndElement name' :) - goN [] = id - goN [x] = goN' x - goN (x:xs) = goN' x . goN xs - goN' (NodeElement e) = goE e - goN' (NodeInstruction i) = (EventInstruction i :) - goN' (NodeContent c) = (EventContent c :) - goN' (NodeComment t) = (EventComment t :) - -elementToEvents :: Element -> [Event] -elementToEvents e@(Element name _ _) = openElementToEvents e ++ [EventEndElement name] - - -renderOpenElement :: Element -> BS.ByteString -renderOpenElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO - $ CL.sourceList (openElementToEvents e) $$ TXSR.renderText def =$ CL.consume - -renderElement :: Element -> BS.ByteString -renderElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO - $ CL.sourceList (elementToEvents e) $$ TXSR.renderText def =$ CL.consume - -ppElement :: Element -> String -ppElement = Text.unpack . Text.decodeUtf8 . renderElement \ No newline at end of file