~singpolyma/network-protocol-xmpp

ref: b78487a01ea84bbb0360046d49458f5b11576c4e network-protocol-xmpp/Network/Protocol/XMPP/Internal/Features.hs -rw-r--r-- 2.4 KiB
b78487a0 — John Millikin Update authentication for public release of gsasl 0.3. 12 years ago 
                                                                                
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
-- 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/>.

module Network.Protocol.XMPP.Internal.Features
	( Feature (..)
	, parseFeatures
	, parseFeature
	) where
import qualified Data.ByteString.Char8 as B
import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A
import qualified Text.XML.HXT.DOM.Interface as DOM
import qualified Text.XML.HXT.DOM.XmlNode as XN
import Network.Protocol.XMPP.Internal.XML (qname)

data Feature =
	  FeatureStartTLS Bool
	| FeatureSASL [B.ByteString]
	| FeatureRegister
	| FeatureBind
	| FeatureSession
	| FeatureUnknown DOM.XmlTree
	deriving (Show, Eq)

parseFeatures :: DOM.XmlTree -> [Feature]
parseFeatures t =
	A.runLA (A.getChildren
		>>> A.hasQName qnameFeatures
		>>> A.getChildren
		>>> A.arrL (\t' -> [parseFeature t'])) t

parseFeature :: DOM.XmlTree -> Feature
parseFeature t = feature where
	mkPair = maybe ("", "") $ \n -> (DOM.namespaceUri n, DOM.localPart n)
	feature = case mkPair (XN.getName t) of
		("urn:ietf:params:xml:ns:xmpp-tls", "starttls") -> parseFeatureTLS t
		("urn:ietf:params:xml:ns:xmpp-sasl", "mechanisms") -> parseFeatureSASL t
		("http://jabber.org/features/iq-register", "register") -> FeatureRegister
		("urn:ietf:params:xml:ns:xmpp-bind", "bind") -> FeatureBind
		("urn:ietf:params:xml:ns:xmpp-session", "session") -> FeatureSession
		_ -> FeatureUnknown t

parseFeatureTLS :: DOM.XmlTree -> Feature
parseFeatureTLS t = FeatureStartTLS True -- TODO: detect whether or not required

parseFeatureSASL :: DOM.XmlTree -> Feature
parseFeatureSASL t = FeatureSASL $ A.runLA (
	A.getChildren
	>>> A.hasQName qnameMechanism
	>>> A.getChildren
	>>> A.getText
	>>> A.arr B.pack) t

qnameMechanism :: DOM.QName
qnameMechanism = qname "urn:ietf:params:xml:ns:xmpp-sasl" "mechanism"

qnameFeatures :: DOM.QName
qnameFeatures = qname "http://etherx.jabber.org/streams" "features"