You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
106 lines
3.7 KiB
106 lines
3.7 KiB
{-# 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 |
|
|
|
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 |