~singpolyma/network-protocol-xmpp

ref: fa4477d23aacb9745b349aaa063892c705861346 network-protocol-xmpp/Network/Protocol/XMPP/XML.hs -rw-r--r-- 3.6 KiB
fa4477d2 — John Millikin Use 'xml-types' instead of HXT for basic XML processing. 12 years ago
                                                                                
fa4477d2 John Millikin
915f7dba John Millikin
fa4477d2 John Millikin
57a89320 John Millikin
fa4477d2 John Millikin
915f7dba John Millikin
fa4477d2 John Millikin
915f7dba John Millikin
fa4477d2 John Millikin
915f7dba 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
-- 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
	, elementChildren
	, hasName
	, getattr
	, getText
	, name
	, nsname
	, element
	, nselement
	, escape
	, serialiseElement
	, readEvents
	, SAX.eventsToElement
	) where
import qualified Data.Text.Lazy as T
import Data.XML.Types
import qualified Text.XML.LibXML.SAX as SAX

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

hasName :: Name -> Element -> [Element]
hasName n e = [e | elementName e == n]

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

getattr :: Name -> Element -> Maybe T.Text
getattr attrname elemt = case filter ((attrname ==) . attributeName) $ elementAttributes elemt of
	[] -> Nothing
	attr:_ -> Just $ attributeValue attr

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

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'