~singpolyma/network-protocol-xmpp

ref: 43693c9c033cf14a26060128b763d565fc93c6b8 network-protocol-xmpp/Network/Protocol/XMPP/XML.hs -rw-r--r-- 3.7 KiB
43693c9c — John Millikin Update for latest version of 'xml-types'. 12 years ago
                                                                                
fa4477d2 John Millikin
915f7dba John Millikin
fa4477d2 John Millikin
57a89320 John Millikin
fa4477d2 John Millikin
32f143cc John Millikin
fa4477d2 John Millikin
915f7dba John Millikin
fa4477d2 John Millikin
32f143cc John Millikin
43e263d7 John Millikin
43693c9c John Millikin
fa4477d2 John Millikin
915f7dba John Millikin
fa4477d2 John Millikin
915f7dba John Millikin
fa4477d2 John Millikin
43e263d7 John Millikin
fa4477d2 John Millikin
43693c9c John Millikin
fa4477d2 John Millikin
43693c9c John Millikin
fa4477d2 John Millikin
43693c9c John Millikin
fa4477d2 John Millikin
43693c9c John Millikin
fa4477d2 John Millikin
43693c9c John Millikin
fa4477d2 John Millikin
43693c9c John Millikin
fa4477d2 John Millikin
d0f194da John Millikin
fa4477d2 John Millikin
43693c9c 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
-- 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
	
	-- * Constructors
	, name
	, nsname
	, element
	, nselement
	
	-- * Misc
	, getattr
	, contentText
	, attributeText
	, 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

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

contentText :: Content -> T.Text
contentText (ContentText t) = t
contentText (ContentEntity e) = T.concat ["&", e, ";"]

attributeText :: Attribute -> T.Text
attributeText = T.concat . map contentText . attributeContent

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

escapeContent :: Content -> T.Text
escapeContent (ContentText t) = escape t
escapeContent (ContentEntity e) = T.concat ["&", escape e, ";"]

element :: T.Text -> [(T.Text, T.Text)] -> [Node] -> Element
element elemName attrs children = Element (name elemName) attrs' children where
	attrs' = map (uncurry mkattr) 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' = map (uncurry mkattr) attrs

mkattr :: T.Text -> T.Text -> Attribute
mkattr n val = Attribute (name n) [ContentText val]

-- 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 c) = T.concat $ [formatName n, "=\""] ++ map escapeContent c ++ ["\""]
	nsattr = case nameNamespace $ elementName e of
		Nothing -> []
		Just ns -> [mkattr "xmlns" ns]
	contents = T.concat $ map serialiseNode $ elementNodes e
	
	serialiseNode (NodeElement e') = serialiseElement e'
	serialiseNode (NodeContent c) = escape (contentText c)
	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'