~singpolyma/network-protocol-xmpp

ref: 32f143cce9d1cef455dbadb7bd8c7474f778fe44 network-protocol-xmpp/Network/Protocol/XMPP/XML.hs -rw-r--r-- 3.7 KiB
32f143cc — John Millikin Small tweaks to the bundled XML combinators. 12 years ago
                                                                                
fa4477d2 John Millikin
915f7dba John Millikin
fa4477d2 John Millikin
57a89320 John Millikin
fa4477d2 John Millikin
32f143cc John Millikin
fa4477d2 John Millikin
32f143cc John Millikin
fa4477d2 John Millikin
32f143cc John Millikin
fa4477d2 John Millikin
915f7dba John Millikin
fa4477d2 John Millikin
32f143cc John Millikin
fa4477d2 John Millikin
915f7dba John Millikin
32f143cc John Millikin
fa4477d2 John Millikin
915f7dba John Millikin
fa4477d2 John Millikin
32f143cc John Millikin
fa4477d2 John Millikin
32f143cc John Millikin
fa4477d2 John Millikin
d0f194da John Millikin
fa4477d2 John Millikin
d0f194da John Millikin
fa4477d2 John Millikin
d0f194da John Millikin
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
-- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>
-- 
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- any later version.
-- 
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.XML
	( module Data.XML.Types
	-- * Filters
	, isElement
	, isText
	, elementChildren
	, named
	, getattr
	
	-- * Constructors
	, name
	, nsname
	, element
	, nselement
	
	-- * Misc
	, escape
	, serialiseElement
	, readEvents
	, SAX.eventsToElement
	) where
import Control.Monad ((>=>))
import qualified Data.Text.Lazy as T
import Data.XML.Types
import qualified Text.XML.LibXML.SAX as SAX

isElement :: Node -> [Element]
isElement (NodeElement e) = [e]
isElement _ = []

isText :: Node -> [T.Text]
isText (NodeText t) = [t]
isText _ = []

elementChildren :: Element -> [Element]
elementChildren = elementNodes >=> isElement

named :: Named a => Name -> a -> [a]
named n x = [x | getName x == n]

getattr :: Name -> Element -> Maybe T.Text
getattr n e = case elementAttributes e >>= named n of
	[] -> Nothing
	attr:_ -> Just $ attributeValue attr

name :: T.Text -> Name
name t = Name t Nothing Nothing

nsname :: T.Text -> T.Text -> Name
nsname ns n = Name n (Just ns) Nothing

escape :: T.Text -> T.Text
escape = T.concatMap escapeChar where
	escapeChar c = case c of
		'&' -> "&amp;"
		'<' -> "&lt;"
		'>' -> "&gt;"
		'"' -> "&quot;"
		'\'' -> "&apos;"
		_ -> T.singleton c

element :: T.Text -> [(T.Text, T.Text)] -> [Node] -> Element
element elemName attrs children = Element (name elemName) attrs' children where
	attrs' = [Attribute (name n) value | (n, value) <- attrs]

nselement :: T.Text -> T.Text -> [(T.Text, T.Text)] -> [Node] -> Element
nselement ns ln attrs children = Element (nsname ns ln) attrs' children where
	attrs' = [Attribute (name n) value | (n, value) <- attrs]

-- A somewhat primitive serialisation function
--
-- TODO: better namespace / prefix handling
serialiseElement :: Element -> T.Text
serialiseElement e = text where
	text = T.concat ["<", eName, " ", attrs, ">", contents, "</", eName, ">"]
	eName = formatName $ elementName e
	formatName = escape . nameLocalName
	attrs = T.intercalate " " $ map attr $ elementAttributes e ++ nsattr
	attr (Attribute n v) = T.concat [formatName n, "=\"", escape v, "\""]
	nsattr = case nameNamespace $ elementName e of
		Nothing -> []
		Just ns -> [Attribute (name "xmlns") ns]
	contents = T.concat $ map serialiseNode $ elementNodes e
	
	serialiseNode (NodeElement e') = serialiseElement e'
	serialiseNode (NodeText t) = escape t
	serialiseNode (NodeComment _) = ""
	serialiseNode (NodeInstruction _) = ""

readEvents :: Monad m
           => (Integer -> SAX.Event -> Bool)
           -> m [SAX.Event]
           -> m [SAX.Event]
readEvents done nextEvents = readEvents' 0 [] where
	readEvents' depth acc = do
		events <- nextEvents
		let (done', depth', acc') = step events depth acc
		if done'
			then return acc'
			else readEvents' depth' acc'
	
	step [] depth acc = (False, depth, acc)
	step (e:es) depth acc = let
		depth' = depth + case e of
			(SAX.BeginElement _ _) -> 1
			(SAX.EndElement _) -> (- 1)
			_ -> 0
		acc' = e : acc
		in if done depth' e
			then (True, depth', reverse acc')
			else step es depth' acc'