Browse Source

some cleanup

master
Philipp Balzarek 14 years ago
parent
commit
7013553dee
  1. 10
      .gitmodules
  2. 1
      hexpat-internals
  3. 141
      src/Data/Conduit/Hexpat.hs
  4. 22
      src/xml-conduit-testcase.hs
  5. 1
      xml
  6. 1
      xmpp-lib.cabal

10
.gitmodules vendored

@ -1,9 +1,3 @@ @@ -1,9 +1,3 @@
[submodule "xml"]
path = xml
url = https://github.com/snoyberg/xml.git
[submodule "xml-types-pickle"]
path = xml-types-pickle
url = git@github.com:Philonous/xml-types-pickle.git
[submodule "hexpat-internals"]
path = hexpat-internals
url = git@github.com:Philonous/hexpat-internals.git
path = xml-types-pickle
url = git@github.com:Philonous/xml-types-pickle.git

1
hexpat-internals

@ -1 +0,0 @@ @@ -1 +0,0 @@
Subproject commit 55c95b082eaa37836822d23bf3313cc8b1ad71af

141
src/Data/Conduit/Hexpat.hs

@ -1,141 +0,0 @@ @@ -1,141 +0,0 @@
{-# LANGUAGE DeriveDataTypeable, NoMonomorphismRestriction #-}
module Data.Conduit.Hexpat
( ParseOptions(..)
, defaultParseOptions
, parseBS
)
where
import Control.Applicative((<$>))
import Control.Exception
import Control.Monad
import Control.Monad.Trans.Class
import qualified Data.ByteString as BS
import Data.Conduit as C
import qualified Data.Text as Text
import qualified Data.Text.Encoding as TE
import Data.Text(Text)
import Data.Typeable
import Data.XML.Types as XML
import Text.XML.Expat.Internal.IO hiding (parse)
import Data.IORef
-- adapted from parseG
-- | Parse a generalized list of ByteStrings containing XML to SAX events.
-- In the event of an error, FailDocument is the last element of the output list.
data HexpatParser = HexpatParser
{ hParser :: Parser
, hQueueRef :: IORef [XML.Event]
}
splitName :: Text -> Name
splitName name = case Text.split (=='}') name of
[n] -> case Text.split (==':') n of
[n'] -> Name n' Nothing Nothing
[p,n'] -> Name n' Nothing (Just p)
_ -> throw . HexpatParseException
$ "Error parsing name: " ++ show name
[ns,n] -> Name n (Just ns) Nothing
_ -> throw . HexpatParseException
$ "Error parsing name: " ++ show name
createParser :: ParseOptions -> Maybe Char -> IO (HexpatParser)
createParser opts delim = do
let enc = overrideEncoding opts
-- let mEntityDecoder = entityDecoder opts
parser <- newParser enc delim
queueRef <- newIORef []
-- setXMLDeclarationHandler parser $ \_ cVer cEnc cSd -> do
-- ver <- textFromCString cVer
-- mEnc <- if cEnc == nullPtr
-- then return Nothing
-- else Just <$> textFromCString cEnc
-- let sd = if cSd < 0
-- then Nothing
-- else Just $ if cSd /= 0 then True else False
-- modifyIORef queueRef (XMLDeclaration ver mEnc sd:)
-- TODO: What to do here?
-- return True
setStartElementHandler parser $ \_ cName cAttrs -> do
name <- splitName <$> textFromCString cName
attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do
attrName <- splitName <$> textFromCString cAttrName
attrValue <- ContentText <$> textFromCString cAttrValue
return (attrName, [attrValue])
modifyIORef queueRef (EventBeginElement name attrs:)
return True
setEndElementHandler parser $ \_ cName -> do
name <- splitName <$> textFromCString cName
modifyIORef queueRef (EventEndElement name:)
return True
setCharacterDataHandler parser $ \_ cText -> do
txt <- TE.decodeUtf8 <$> BS.packCStringLen cText
modifyIORef queueRef ((EventContent $ ContentText txt):)
return True
setProcessingInstructionHandler parser $ \_ cTarget cText -> do
target <- textFromCString cTarget
txt <- textFromCString cText
modifyIORef queueRef (EventInstruction (Instruction target txt) :)
return True
setCommentHandler parser $ \_ cText -> do
txt <- textFromCString cText
modifyIORef queueRef (EventComment txt :)
return True
return (HexpatParser parser queueRef)
data HexpatParseException = HexpatParseException String deriving (Typeable, Show)
instance Exception HexpatParseException
parseBS
:: (MonadResource (t IO), MonadTrans t) =>
ParseOptions -> Conduit BS.ByteString (t IO) Event
parseBS opts = conduitIO
(createParser opts (Just '}'))
(\_ -> return ())
(\(HexpatParser parser queueRef) input -> lift $ do
e <- withParser parser $ \pp -> parseChunk pp input False
case e of
Nothing -> return ()
Just (XMLParseError err _) ->
throwIO $ HexpatParseException err
queue <- readIORef queueRef
writeIORef queueRef []
return . IOProducing $ reverse queue
)
(\(HexpatParser parser queueRef) -> lift $ do
e <- withParser parser $ \pp -> parseChunk pp BS.empty True
case e of
Nothing -> return ()
Just (XMLParseError err _) ->
throwIO $ HexpatParseException err
queue <- readIORef queueRef
writeIORef queueRef []
return $ reverse queue
)
whileJust :: Monad m => m (Maybe a) -> m [a]
whileJust f = do
f' <- f
case f' of
Just x -> liftM (x :) $ whileJust f
Nothing -> return []
data StreamUnfinishedException = StreamUnfinishedException deriving (Typeable, Show)
instance Exception StreamUnfinishedException

22
src/xml-conduit-testcase.hs

@ -1,22 +0,0 @@ @@ -1,22 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Test where
import qualified Data.ByteString as BS
import Data.Conduit
import Data.Default
import qualified Data.Conduit.List as CL
import qualified Text.XML.Stream.Parse as XP
xml =
[ "<?xml version='1.0'?>"
, "<stream:stream xmlns='jabber:client' "
, "xmlns:stream='http://etherx.jabber.org/streams' id='1365401808' "
, "from='examplehost.org' version='1.0' xml:lang='en'>"
, "<stream:features>"
, "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>"
, error "Booh!"
] :: [BS.ByteString]
main :: IO ()
main = (runResourceT $ CL.sourceList xml $= XP.parseBytes def $$ CL.take 2 )
>>= print

1
xml

@ -1 +0,0 @@ @@ -1 +0,0 @@
Subproject commit e5b4238b214f288cea822222876baf7d3f02699a

1
xmpp-lib.cabal

@ -29,7 +29,6 @@ library @@ -29,7 +29,6 @@ library
, resourcet -any
, containers -any
, random -any
, hexpat-internals -any
, tls -any
, tls-extra -any
, pureMD5 -any

Loading…
Cancel
Save