packages feed

xml-pipe (empty) → 0.0.0.0

raw patch · 9 files changed

+593/−0 lines, 9 filesdep +basedep +bytestringdep +papillonsetup-changed

Dependencies added: base, bytestring, papillon, simple-pipe

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2014, Yoshikuni Jujo+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++  * Redistributions of source code must retain the above copyright notice,+    this list of conditions and the following disclaimer.++  * Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in the+    documentation and/or other materials provided with the distribution.++  * Neither the name of the Yoshikuni Jujo nor the names of its+    contributors may be used to endorse or promote products derived from+    this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVEN SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,1 @@+import Distribution.Simple; main = defaultMain
+ examples/indians.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++import Control.Monad+import "monads-tf" Control.Monad.Trans+import Data.Maybe+import Data.Pipe+import Data.Pipe.List+import Text.XML.Pipe++import qualified Data.ByteString.Char8 as BSC++littleIndians :: Int -> BSC.ByteString+littleIndians n = "<indians>" `BSC.append`+	BSC.pack (show n) `BSC.append` " little, " `BSC.append`+	BSC.pack (show $ n + 1) `BSC.append` " little, " `BSC.append`+	BSC.pack (show $ n + 2) `BSC.append` " little Indians" `BSC.append`+	"</indians>"++infiniteIndians :: [BSC.ByteString]+infiniteIndians = map littleIndians [1, 4 .. ]++xml :: [BSC.ByteString]+xml = "<?xml version='1.0'?><song>" : infiniteIndians++main :: IO ()+main = void . runPipe $ fromList xml+	=$= xmlEvent+	=$= convert fromJust+	=$= (xmlBegin >>= xmlNode)+	=$= takeP 8+	=$= printP++takeP :: Monad m => Int -> Pipe a a m ()+takeP 0 = return ()+takeP n = do+	mx <- await+	maybe (return ()) (\x -> yield x >> takeP (n - 1)) mx++convert :: Monad m => (a -> b) -> Pipe a b m ()+convert f = do+	mx <- await+	maybe (return ()) (\x -> yield (f x) >> convert f) mx++printP :: Show a => Pipe a () IO ()+printP = do+	mx <- await+	maybe (return ()) (\x -> lift (print x) >> printP) mx
+ src/Text/XML/Lexer.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}++module Text.XML.Lexer (sepTag) where++-- import "monads-tf" Control.Monad.Trans+import Data.Pipe+-- import Data.Pipe.List+-- import Data.Word8+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC++endWith :: Monad m =>+	(Char -> Bool) -> Char -> BS.ByteString -> Pipe BS.ByteString BS.ByteString m ()+endWith p c rest = do+	let (t, d) = BSC.span (not . p) rest+	if BS.null d+	then do	mbs <- await+		case mbs of+			Just bs -> endWith p c $ t `BS.append` bs+			_ -> return ()+	else yield (BSC.cons c t) >> endWith p (BSC.head d) (BS.tail d)++-- endByDot :: Monad m => Pipe BS.ByteString BS.ByteString m ()+-- -- -- -- -- -- -- -- endByDot = endWith (== '.') '.' ""++sepTag :: Monad m => Pipe BS.ByteString BS.ByteString m ()+sepTag = endWith (`elem` "<>") '>' ""++{-+endByDot :: Monad m => BS.ByteString -> Pipe BS.ByteString BS.ByteString m ()+endByDot rest = do+	let (t, d) = BS.span (/= 46) rest+	if BS.null d+	then do	mbs <- await+		case mbs of+			Just bs -> endByDot $ t `BS.append` bs+			_ -> return ()+	else yield t >> endByDot (BS.tail d)+	-}++{-+bsToUpper :: BS.ByteString -> BS.ByteString+bsToUpper = BS.pack . map toUpper . BS.unpack++upper :: Monad m => Pipe BS.ByteString BS.ByteString m ()+upper = await >>= maybe (return ()) (\bs -> yield (bsToUpper bs) >> upper)+-}
+ src/Text/XML/Papillon.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Text.XML.Papillon(Xmlns, XEQName, parseXmlEvent, XmlEvent(..)) where++import Control.Arrow+import Data.List+import Data.Char+import Data.ByteString.Char8 (ByteString, pack)+import Text.Papillon+import Numeric++import qualified Data.ByteString.Char8 as BSC++type Xmlns = (BSC.ByteString, BSC.ByteString)+type XEQName = (BSC.ByteString, BSC.ByteString)++data XmlEvent+	= XEXmlDecl (Int, Int)+	| XESTag XEQName [Xmlns] [(XEQName, BSC.ByteString)]+	| XEETag XEQName+	| XEEmptyElemTag XEQName [Xmlns] [(XEQName, BSC.ByteString)]+	| XECharData BSC.ByteString+	deriving Show++data Attribute+	= NSAttribute BSC.ByteString BSC.ByteString+	| Attribute (BSC.ByteString, BSC.ByteString) BSC.ByteString+	deriving Show++procAtts :: [Attribute] -> (+	[(BSC.ByteString, BSC.ByteString)],+	[((BSC.ByteString, BSC.ByteString), BSC.ByteString)])+procAtts = (map fromNSAttribute *** map fromAttribute) . partition isNSAtt++fromNSAttribute :: Attribute -> (BSC.ByteString, BSC.ByteString)+fromNSAttribute (NSAttribute k v) = (k, v)+fromNSAttribute _ = error "bad"++fromAttribute :: Attribute -> ((BSC.ByteString, BSC.ByteString), BSC.ByteString)+fromAttribute (Attribute k v) = (k, v)+fromAttribute _ = error "bad"++isNSAtt :: Attribute -> Bool+isNSAtt (NSAttribute _ _) = True+isNSAtt _ = False++parseXmlEvent :: ByteString -> Maybe XmlEvent+parseXmlEvent = either (const Nothing) (Just . fst) . runError . xmlEvent . parse++fromHex :: String -> Char+fromHex = chr . fst . head . readHex++[papillon|++source: ByteString++xmlEvent :: XmlEvent+	= et:emptyElemTag	{ et }+	/ st:sTag		{ st }+	/ et:eTag		{ et }+	/ cd:charData		{ cd }+	/ xd:xmlDecl		{ xd }++spaces = _:(' ' / '\t' / '\r' / '\n')+++nameStartChar :: Char = <(`elem` (":_" ++ ['a' .. 'z'] ++ ['A' .. 'Z']))>++nameChar :: Char+	= s:nameStartChar				{ s }+	/ <(`elem` ("-." ++ ['0' .. '9']))>++ncNameStartChar :: Char = !':' s:nameStartChar		{ s }++ncNameChar :: Char = !':' c:nameChar			{ c }++-- name :: ByteString+--	= sc:nameStartChar cs:(c:nameChar { c })*	{ pack $ sc : cs }++ncName :: ByteString+	= sc:ncNameStartChar cs:(c:ncNameChar { c })*	{ pack $ sc : cs }++qName :: (ByteString, ByteString)+	= pn:prefixedName				{ pn }+	/ un:unprefixedName				{ ("", un) }++prefixedName :: (ByteString, ByteString) = p:prefix ':' l:localPart+							{ (p, l) }+unprefixedName :: ByteString = l:localPart		{ l }+prefix :: ByteString = n:ncName				{ n }+localPart :: ByteString = n:ncName			{ n }++attValue :: ByteString+	= '"' v:(c:<(`notElem` "<&\"")> { c } / c:charEntRef { c })* '"'+							{ pack v }+	/ '\'' v:(c:<(`notElem` "<&'")> { c } / c:charEntRef { c })* '\''+							{ pack v }++charData :: XmlEvent+	= '>' cds:(c:<(`notElem` "<&")> { c } / c:charEntRef { c })*+							{ XECharData $ pack cds }++charEntRef :: Char = c:charRef { c } / c:entityRef { c }++charRef :: Char = '&' '#' 'x'+	ds:(<(`elem` "0123456789abcdefABCDEF")>)+ ';'	{ fromHex ds }++entityRef :: Char+	= '&' 'a' 'm' 'p' ';'				{ '&' }+	/ '&' 'l' 't' ';'				{ '<' }+	/ '&' 'g' 't' ';'				{ '>' }+	/ '&' 'q' 'u' 'o' 't' ';'			{ '"' }+	/ '&' 'a' 'p' 'o' 's' ';'			{ '\'' }++xmlDecl :: XmlEvent+	= '<' '?' 'x' 'm' 'l' vi:versionInfo _:spaces? '?' _:eof+	{ XEXmlDecl vi }++versionInfo :: (Int, Int)+	= _:spaces 'v' 'e' 'r' 's' 'i' 'o' 'n' _:eq+		vn:('"' v:versionNum '"' { v } / '\'' v:versionNum '\'' { v })+	{ vn }++eq :: () = _:spaces? '=' _:spaces?++versionNum :: (Int, Int)+	= '1' '.' d:<isDigit>+				{ (1, read d) }++sTag :: XmlEvent+	= '<' n:qName as:(_:spaces a:attribute { a })* _:spaces? _:eof+	{ uncurry (XESTag n) $ procAtts as }++emptyElemTag :: XmlEvent+	= '<' n:qName as:(_:spaces a:attribute { a })* _:spaces? '/' _:eof+	{ uncurry (XEEmptyElemTag n) $ procAtts as }++prefixedAttName :: ByteString+	= 'x' 'm' 'l' 'n' 's' ':' n:ncName		{ n }++defaultAttName = 'x' 'm' 'l' 'n' 's'++nsAttName :: ByteString+	= n:prefixedAttName				{ n }+	/ _:defaultAttName				{ "" }++attribute :: Attribute+	= n:nsAttName _:eq v:attValue			{ NSAttribute n v }+	/ n:qName _:eq v:attValue			{ Attribute n v }++eTag :: XmlEvent+	= '<' '/' n:qName _:spaces? _:eof	{ XEETag n }++eof = !_++|]++instance Source ByteString where+	type Token ByteString = Char+	data Pos ByteString = NoPos+	getToken = BSC.uncons+	initialPos = NoPos+	updatePos _ _ = NoPos
+ src/Text/XML/Pipe.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE OverloadedStrings #-}++module Text.XML.Pipe (+	-- * Functions+	-- ** Decode+	xmlEvent, xmlBegin, xmlNode, xmlNodeUntil,+	-- ** Encode+	xmlString,+	-- * Types+	XmlEvent(..), XmlNode(..),+	-- ** Type Synonyms+	XEQName, Xmlns, QName) where++import Control.Arrow++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC++import Text.XML.XmlCreate++xmlString :: [XmlNode] -> BS.ByteString+xmlString = BS.concat . map eventToS . toEvent++toEvent :: [XmlNode] -> [XmlEvent]+toEvent [] = []+toEvent (XmlDecl v : ns) = XEXmlDecl v : toEvent ns+toEvent (XmlStart ((q, _), n) nss atts : ns) =+	XESTag (q, n) nss (map (first $ first fst) atts) : toEvent ns+toEvent (XmlNode ((q, _), n) nss atts ns : ns') =+	XESTag (q, n) nss (map (first $ first fst) atts) :+		toEvent ns ++ [XEETag (q, n)] ++ toEvent ns'+toEvent (XmlCharData cd : ns) = XECharData cd : toEvent ns++eventToS :: XmlEvent -> BS.ByteString+eventToS (XEXmlDecl (j, n)) = BS.concat [+	"<?xml version='", BSC.pack $ show j, ".",  BSC.pack $ show n, "'?>" ]+eventToS (XESTag qn nss atts) = BS.concat [+	"<", qNameToS qn,+	BS.concat $ map nsToS nss,+	BS.concat $ map attToS atts, ">" ]+eventToS (XEETag qn) = BS.concat ["</", qNameToS qn, ">"]+eventToS (XEEmptyElemTag qn nss atts) = BS.concat [+	"<", qNameToS qn,+	BS.concat $ map nsToS nss,+	BS.concat $ map attToS atts, "/>" ]+eventToS (XECharData cd) = quote cd++qNameToS :: (BS.ByteString, BS.ByteString) -> BS.ByteString+qNameToS ("", n) = n+qNameToS (q, n) = BS.concat [q, ":", n]++nsToS :: (BS.ByteString, BS.ByteString) -> BS.ByteString+nsToS ("", s) = BS.concat [" xmlns='", s, "'"]+nsToS (ns, s) = BS.concat [" xmlns:", ns, "='", s, "'"]++attToS :: ((BS.ByteString, BS.ByteString), BS.ByteString) -> BS.ByteString+attToS (qn, v) = BS.concat [" ", qNameToS qn, "='", quote v, "'"]++quote :: BS.ByteString -> BS.ByteString+quote bs+	| Just (h, t) <- BSC.uncons bs = case h of+		'&' -> "&amp;" `BS.append` quote t+		'<' -> "&lt;" `BS.append` quote t+		'>' -> "&gt;" `BS.append` quote t+		'"' -> "&quot;" `BS.append` quote t+		'\'' -> "&apos;" `BS.append` quote t+		_ -> h `BSC.cons` quote t+	| otherwise = ""
+ src/Text/XML/XmlCreate.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE OverloadedStrings #-}++module Text.XML.XmlCreate (+	xmlEvent, XmlEvent(..), XmlNode(..), xmlBegin, xmlNode, xmlNodeUntil,+	QName, Xmlns, XEQName) where++import Control.Applicative+import Control.Arrow+import Control.Monad+import Data.Pipe+import qualified Data.ByteString as BS++import Text.XML.XmlEvent++type QName = ((BS.ByteString, Maybe BS.ByteString), BS.ByteString)++data XmlNode+	= XmlDecl (Int, Int)+	| XmlStart QName [Xmlns] [(QName, BS.ByteString)]+--	| XmlEnd QName+	| XmlNode QName [Xmlns] [(QName, BS.ByteString)] [XmlNode]+	| XmlCharData BS.ByteString+	deriving Show++toQName ::+	[(BS.ByteString, BS.ByteString)] -> (BS.ByteString, BS.ByteString) -> QName+toQName nss (q, n) = ((q, lookup q nss), n)++xmlBegin :: Monad m => Pipe XmlEvent XmlNode m [(BS.ByteString, BS.ByteString)]+xmlBegin = do+	mxe <- await+	case mxe of+		Just (XESTag n nss atts) -> do+			yield $ XmlStart (toQName nss n) nss+				(map (first $ toQName nss) atts)+			return nss+		Nothing -> return []+		_ -> xmlBegin++xmlNodeUntil :: Monad m => (XmlNode -> Bool) ->+	[(BS.ByteString, BS.ByteString)] -> Pipe XmlEvent XmlNode m ()+xmlNodeUntil p nss = do+	mnd <- xmlNd nss+	case mnd of+		Right nd -> do+			yield nd+			unless (p nd) $ xmlNodeUntil p nss+		Left (XEXmlDecl _) -> return ()+		_ -> return ()++xmlNode :: Monad m =>+	[(BS.ByteString, BS.ByteString)] -> Pipe XmlEvent XmlNode m Bool+xmlNode nss = do+	mnd <- xmlNd nss+	case mnd of+		Right nd -> yield nd >> xmlNode nss+		Left (XEXmlDecl _) -> return True+		_ -> return False++xmlNd :: Monad m =>+	[(BS.ByteString, BS.ByteString)] -> Pipe XmlEvent a m (Either XmlEvent XmlNode)+xmlNd nss = do+	mxe <- await+	case mxe of+		Just (XESTag n nss' atts) -> do+			nds <- xmlNds (nss' ++ nss)+			return . Right $ XmlNode (toQName (nss' ++ nss) n) nss'+				(map (first $ toQName (nss' ++ nss)) atts) nds+		Just (XEEmptyElemTag n nss' atts) ->+			return . Right $ XmlNode (toQName (nss' ++ nss) n) nss'+				(map (first $ toQName (nss' ++ nss)) atts) []+--		Just (XEETag n) -> return $ Left (XEE+		Just (XECharData cd) -> return . Right $ XmlCharData cd+--		Just (XEXmlDecl v) -> return . Just $ XmlDecl v+		Just xe -> return $ Left xe+		Nothing -> return . Left $ XECharData ""+--		_ -> error $ "bad in xmlNd: " ++ show mxe+--		_ -> error $ "bad: " ++ show mxe++xmlNds :: Monad m => [(BS.ByteString, BS.ByteString)] -> Pipe XmlEvent a m [XmlNode]+xmlNds nss = do+	mxn <- xmlNd nss+	case mxn of+		Right xn -> (xn :) <$> xmlNds nss+		_ -> return []+{-+	mxe <- await+	case mxe of+		Just (XESTag n nss' atts) -> do+			nds <- xmlNds nss+			return . (: nds) $ XmlNode (toQName (nss ++ nss') n)+				(map (first $ toQName (nss ++ nss')) atts) []+		_ -> return []+		-}
+ src/Text/XML/XmlEvent.hs view
@@ -0,0 +1,24 @@+module Text.XML.XmlEvent (xmlEvent, XmlEvent(..), Xmlns, XEQName) where++import Control.Monad+import Data.Pipe+import Data.Char+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC++import Text.XML.Lexer+import Text.XML.Papillon++xmlEvent :: Monad m => Pipe BS.ByteString (Maybe XmlEvent) m ()+xmlEvent = sepTag =$= convert parseXmlEvent =$= filterP (maybe True notEmpty)++notEmpty :: XmlEvent -> Bool+notEmpty (XECharData cd) = not $ BSC.all isSpace cd+notEmpty _ = True++convert :: Monad m => (a -> b) -> Pipe a b m ()+convert f = await >>= maybe (return ()) (\x -> yield (f x) >> convert f)++filterP :: Monad m => (a -> Bool) -> Pipe a a m ()+filterP p = await >>=+	maybe (return ()) (\x -> when (p x) (yield x) >> filterP p)
+ xml-pipe.cabal view
@@ -0,0 +1,123 @@+build-type:	Simple+cabal-version:	>= 1.8++name:		xml-pipe+version:	0.0.0.0+stability:	Experimental+author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp>+maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>+homepage:	https://github.com/YoshikuniJujo/xml-pipe/wiki++license:	BSD3+license-file:	LICENSE++category:	XML+synopsis:	XML parser which uses simple-pipe+description:+    This package process subset of XML and is still far from perfect, now.+    .+    Example programs+    .+    examples/indians.hs+    .+    extensions+    .+    * OverloadedStrings+    .+    * PackageImports+    .+    > import Control.Monad+    > import "monads-tf" Control.Monad.Trans+    > import Data.Maybe+    > import Data.Pipe+    > import Data.Pipe.List+    > import Text.XML.Pipe+    >+    > import qualified Data.ByteString.Char8 as BSC+    >+    > littleIndians :: Int -> BSC.ByteString+    > littleIndians n = "<indians>" `BSC.append`+    > 	BSC.pack (show n) `BSC.append` " little, " `BSC.append`+    > 	BSC.pack (show $ n + 1) `BSC.append` " little, " `BSC.append`+    > 	BSC.pack (show $ n + 2) `BSC.append` " little Indians" `BSC.append`+    > 	"</indians>"+    >+    > infiniteIndians :: [BSC.ByteString]+    > infiniteIndians = map littleIndians [1, 4 .. ]+    >+    > xml :: [BSC.ByteString]+    > xml = "<?xml version='1.0'?><song>" : infiniteIndians+    >+    > main :: IO ()+    > main = void . runPipe $ fromList xml+    > 	=$= xmlEvent+    > 	=$= convert fromJust+    > 	=$= (xmlBegin >>= xmlNode)+    > 	=$= takeP 8+    > 	=$= printP+    >+    > takeP :: Monad m => Int -> Pipe a a m ()+    > takeP 0 = return ()+    > takeP n = do+    > 	mx <- await+    > 	maybe (return ()) (\x -> yield x >> takeP (n - 1)) mx+    >+    > convert :: Monad m => (a -> b) -> Pipe a b m ()+    > convert f = do+    > 	mx <- await+    > 	maybe (return ()) (\x -> yield (f x) >> convert f) mx+    >+    > printP :: Show a => Pipe a () IO ()+    > printP = do+    > 	mx <- await+    > 	maybe (return ()) (\x -> lift (print x) >> printP) mx+    .+    examples/starttls.hs+    .+    It process STARTTLS of XMPP as client.+    The fllowings are only main part.+    .+    > main :: IO ()+    > main = do+    > 	h <- connectTo "localhost" (PortNumber 5222)+    > 	BS.hPut h $ xmlString begin+    > 	BS.hPut h $ xmlString startTls+    > 	void . runPipe $ handleP h+    > 		=$= xmlEvent+    > 		=$= convert fromJust+    > 		=$= (xmlBegin >>= xmlNodeUntil isProceed)+    > 		=$= printP+    > 	ca <- readCertificateStore ["cacert.sample_pem"]+    > 	g <- cprgCreate <$> createEntropyPool :: IO SystemRNG+    > 	(`run` g) $ do+    > 		p <- open' h "localhost" ["TLS_RSA_WITH_AES_128_CBC_SHA"] [] ca+    > 		hlPut p $ xmlString begin+    > 		void . runPipe $ handleP p+    > 			=$= xmlEvent+    > 			=$= convert fromJust+    > 			=$= (xmlBegin >>= xmlNode)+    > 			=$= printP+    .++extra-source-files:+    examples/indians.hs++source-repository	head+    type:	git+    location:	git://github.com/YoshikuniJujo/xml-pipe.git++source-repository	this+    type:	git+    location:	git://github.com/YoshikuniJujo/xml-pipe.git+    tag:	xml-pipe-0.0.0.0++library+    hs-source-dirs:	src+    exposed-modules:	Text.XML.Pipe+    other-modules:+        Text.XML.XmlEvent, Text.XML.Lexer, Text.XML.Papillon, Text.XML.XmlCreate+    build-depends:+        base == 4.*, bytestring == 0.10.*, simple-pipe == 0.0.0.6,+        papillon == 0.0.88+    ghc-options:	-Wall+    extensions:		DoAndIfThenElse, PatternGuards