~singpolyma/network-protocol-xmpp

57a8932024bc67e6759cefc5be86329b4a849bff — John Millikin 13 years ago b78487a
Merged public API into a single exposed module, 'Network.Protocol.XMPP'.
14 files changed, 347 insertions(+), 348 deletions(-)

M Network/Protocol/XMPP.hs
R Network/Protocol/XMPP/{Internal/Authentication.hs => Authentication.hs}
M Network/Protocol/XMPP/Client.hs
M Network/Protocol/XMPP/Component.hs
R Network/Protocol/XMPP/{Internal/Connections.hs => Connections.hs}
R Network/Protocol/XMPP/{Internal/Features.hs => Features.hs}
R Network/Protocol/XMPP/{Internal/Handle.hs => Handle.hs}
D Network/Protocol/XMPP/Internal/Stanza.hs
D Network/Protocol/XMPP/Internal/Stream.hs
M Network/Protocol/XMPP/JID.hs
M Network/Protocol/XMPP/Stanza.hs
M Network/Protocol/XMPP/Stream.hs
R Network/Protocol/XMPP/{Internal/XML.hs => XML.hs}
M network-protocol-xmpp.cabal
M Network/Protocol/XMPP.hs => Network/Protocol/XMPP.hs +56 -11
@@ 15,19 15,64 @@


module Network.Protocol.XMPP
	( module Network.Protocol.XMPP.Client
	, module Network.Protocol.XMPP.Component
	, module Network.Protocol.XMPP.JID
	, module Network.Protocol.XMPP.Stanza
	, module Network.Protocol.XMPP.Stream
	( 
	-- * JIDs
	  JID (..)
	, Node
	, Domain
	, Resource
	
	, strNode
	, strDomain
	, strResource
	
	, parseJID
	, formatJID
	
	-- * Stanzas
	, Stanza
		( stanzaTo
		, stanzaFrom
		, stanzaID
		, stanzaLang
		, stanzaPayloads
		)
	
	, ReceivedStanza (..)
	, Message (..)
	, Presence (..)
	, IQ (..)
	, MessageType (..)
	, PresenceType (..)
	, IQType (..)
	
	, emptyMessage
	, emptyPresence
	, emptyIQ
	
	-- * Streams
	, Stream
	, putStanza
	, getStanza
	
	-- * Connecting to a server
	, Server (..)
	
	-- ** Clients
	, Client
	, connectClient
	, clientJID
	, bindClient
	
	-- ** Components
	, Component
	, connectComponent
	, componentJID
	, componentStreamID
	) where

import Network.Protocol.XMPP.JID
import Network.Protocol.XMPP.Client
import Network.Protocol.XMPP.Component
import Network.Protocol.XMPP.JID
import Network.Protocol.XMPP.Stanza
import Network.Protocol.XMPP.Connections
import Network.Protocol.XMPP.Stream


import Network.Protocol.XMPP.Internal.Connections
import Network.Protocol.XMPP.Stanza

R Network/Protocol/XMPP/Internal/Authentication.hs => Network/Protocol/XMPP/Authentication.hs +3 -3
@@ 13,7 13,7 @@
-- 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.Authentication
module Network.Protocol.XMPP.Authentication
	( Result(..)
	, authenticate
	) where


@@ 28,8 28,8 @@ import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified Network.Protocol.SASL.GNU as SASL

import Network.Protocol.XMPP.JID (JID, formatJID)
import Network.Protocol.XMPP.Internal.XML (element, qname)
import qualified Network.Protocol.XMPP.Internal.Stream as S
import Network.Protocol.XMPP.XML (element, qname)
import qualified Network.Protocol.XMPP.Stream as S

data Result = Success | Failure
	deriving (Show, Eq)

M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +8 -9
@@ 30,16 30,15 @@ import Data.ByteString (ByteString)
import qualified Data.Text as T
import qualified Text.XML.LibXML.SAX as SAX

import qualified Network.Protocol.XMPP.Internal.Authentication as A
import qualified Network.Protocol.XMPP.Internal.Connections as C
import qualified Network.Protocol.XMPP.Internal.Features as F
import qualified Network.Protocol.XMPP.Internal.Handle as H
import qualified Network.Protocol.XMPP.Internal.Stream as S
import qualified Network.Protocol.XMPP.Authentication as A
import qualified Network.Protocol.XMPP.Connections as C
import qualified Network.Protocol.XMPP.Features as F
import qualified Network.Protocol.XMPP.Handle as H
import qualified Network.Protocol.XMPP.Stream as S
import Network.Protocol.XMPP.Internal.XML ( getTree, putTree
                                                 , element, qname
                                                 , readEventsUntil
                                                 )
import Network.Protocol.XMPP.XML ( getTree, putTree
                                       , element, qname
                                       , readEventsUntil
                                       )
import qualified Network.Protocol.XMPP.JID as J
import Network.Protocol.XMPP.Stanza


M Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +6 -7
@@ 35,14 35,13 @@ import Network.Protocol.SASL.GNU (sha1)
import qualified System.IO as IO
import qualified Text.XML.LibXML.SAX as SAX

import qualified Network.Protocol.XMPP.Internal.Connections as C
import qualified Network.Protocol.XMPP.Internal.Handle as H
import qualified Network.Protocol.XMPP.Connections as C
import qualified Network.Protocol.XMPP.Handle as H
import qualified Network.Protocol.XMPP.Stream as S
import qualified Network.Protocol.XMPP.Internal.Stream as S
import Network.Protocol.XMPP.Internal.XML ( getTree, putTree
                                                 , element, qname
                                                 , readEventsUntil
                                                 )
import Network.Protocol.XMPP.XML ( getTree, putTree
                                       , element, qname
                                       , readEventsUntil
                                       )
import Network.Protocol.XMPP.JID (JID)

data Component = Component

R Network/Protocol/XMPP/Internal/Connections.hs => Network/Protocol/XMPP/Connections.hs +2 -2
@@ 14,7 14,7 @@
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.Internal.Connections
module Network.Protocol.XMPP.Connections
	( Server (..)
	, xmlHeader
	, startOfStream


@@ 28,7 28,7 @@ import qualified Text.XML.HXT.DOM.Interface as DOM
import qualified Text.XML.LibXML.SAX as SAX

import Network.Protocol.XMPP.JID (JID, formatJID)
import Network.Protocol.XMPP.Internal.XML (qname, convertQName)
import Network.Protocol.XMPP.XML (qname, convertQName)

data Server = Server
	{ serverJID      :: JID

R Network/Protocol/XMPP/Internal/Features.hs => Network/Protocol/XMPP/Features.hs +2 -2
@@ 13,7 13,7 @@
-- 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
module Network.Protocol.XMPP.Features
	( Feature (..)
	, parseFeatures
	, parseFeature


@@ 23,7 23,7 @@ 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)
import Network.Protocol.XMPP.XML (qname)

data Feature =
	  FeatureStartTLS Bool

R Network/Protocol/XMPP/Internal/Handle.hs => Network/Protocol/XMPP/Handle.hs +1 -1
@@ 13,7 13,7 @@
-- 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.Handle
module Network.Protocol.XMPP.Handle
	( Handle (..)
	, startTLS
	, hPutBytes

D Network/Protocol/XMPP/Internal/Stanza.hs => Network/Protocol/XMPP/Internal/Stanza.hs +0 -255
@@ 1,255 0,0 @@
-- 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.Stanza where
import qualified Data.Text as T
import Text.XML.HXT.DOM.Interface (XmlTree)
import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A

import Network.Protocol.XMPP.Internal.XML (element)
import Network.Protocol.XMPP.JID (JID, parseJID, formatJID)

class Stanza a where
	stanzaTo       :: a -> Maybe JID
	stanzaFrom     :: a -> Maybe JID
	stanzaID       :: a -> Maybe T.Text
	stanzaLang     :: a -> Maybe T.Text
	stanzaPayloads :: a -> [XmlTree]
	stanzaToTree   :: a -> XmlTree

data ReceivedStanza
	= ReceivedMessage Message
	| ReceivedPresence Presence
	| ReceivedIQ IQ

data Message = Message
	{ messageType     :: MessageType
	, messageTo       :: Maybe JID
	, messageFrom     :: Maybe JID
	, messageID       :: Maybe T.Text
	, messageLang     :: Maybe T.Text
	, messagePayloads :: [XmlTree]
	}

instance Stanza Message where
	stanzaTo = messageTo
	stanzaFrom = messageFrom
	stanzaID = messageID
	stanzaLang = messageLang
	stanzaPayloads = messagePayloads
	stanzaToTree x = stanzaToTree' x "message" typeStr where
		typeStr = case messageType x of
			MessageNormal -> "normal"
			MessageChat -> "chat"
			MessageGroupChat -> "groupchat"
			MessageHeadline -> "headline"
			MessageError -> "error"

data MessageType
	= MessageNormal
	| MessageChat
	| MessageGroupChat
	| MessageHeadline
	| MessageError
	deriving (Show, Eq)

emptyMessage :: MessageType -> Message
emptyMessage t = Message
	{ messageType = t
	, messageTo = Nothing
	, messageFrom = Nothing
	, messageID = Nothing
	, messageLang = Nothing
	, messagePayloads = []
	}

data Presence = Presence
	{ presenceType     :: PresenceType
	, presenceTo       :: Maybe JID
	, presenceFrom     :: Maybe JID
	, presenceID       :: Maybe T.Text
	, presenceLang     :: Maybe T.Text
	, presencePayloads :: [XmlTree]
	}

instance Stanza Presence where
	stanzaTo = presenceTo
	stanzaFrom = presenceFrom
	stanzaID = presenceID
	stanzaLang = presenceLang
	stanzaPayloads = presencePayloads
	stanzaToTree x = stanzaToTree' x "presence" typeStr where
		typeStr = case presenceType x of
			PresenceAvailable -> ""
			PresenceUnavailable -> "unavailable"
			PresenceSubscribe -> "subscribe"
			PresenceSubscribed -> "subscribed"
			PresenceUnsubscribe -> "unsubscribe"
			PresenceUnsubscribed -> "unsubscribed"
			PresenceProbe -> "probe"
			PresenceError -> "error"

data PresenceType
	= PresenceAvailable
	| PresenceUnavailable
	| PresenceSubscribe
	| PresenceSubscribed
	| PresenceUnsubscribe
	| PresenceUnsubscribed
	| PresenceProbe
	| PresenceError
	deriving (Show, Eq)

emptyPresence :: PresenceType -> Presence
emptyPresence t = Presence
	{ presenceType = t
	, presenceTo = Nothing
	, presenceFrom = Nothing
	, presenceID = Nothing
	, presenceLang = Nothing
	, presencePayloads = []
	}

data IQ = IQ
	{ iqType    :: IQType
	, iqTo      :: Maybe JID
	, iqFrom    :: Maybe JID
	, iqID      :: Maybe T.Text
	, iqLang    :: Maybe T.Text
	, iqPayload :: XmlTree
	}

instance Stanza IQ where
	stanzaTo = iqTo
	stanzaFrom = iqFrom
	stanzaID = iqID
	stanzaLang = iqLang
	stanzaPayloads iq = [iqPayload iq]
	stanzaToTree x = stanzaToTree' x "iq" typeStr where
		typeStr = case iqType x of
			IQGet -> "get"
			IQSet -> "set"
			IQResult -> "result"
			IQError -> "error"

data IQType
	= IQGet
	| IQSet
	| IQResult
	| IQError
	deriving (Show, Eq)

emptyIQ :: IQType -> XmlTree -> IQ
emptyIQ t tree = IQ
	{ iqType = t
	, iqTo = Nothing
	, iqFrom = Nothing
	, iqID = Nothing
	, iqLang = Nothing
	, iqPayload = tree
	}

stanzaToTree' :: Stanza a => a -> String -> String -> XmlTree
stanzaToTree' stanza name typeStr = element ("", name) attrs payloads where
	payloads = stanzaPayloads stanza
	attrs = concat
		[ mattr "to" $ fmap formatJID . stanzaTo
		, mattr "from" $ fmap formatJID . stanzaFrom
		, mattr "id" stanzaID
		, mattr "xml:lang" stanzaLang
		, if null typeStr then [] else [("", "type", typeStr)]
		]
	mattr label f = case f stanza of
		Nothing -> []
		Just text -> [("", label, T.unpack text)]

treeToStanza :: T.Text -> XmlTree -> Maybe ReceivedStanza
treeToStanza ns tree = do
	treeNS <- runMA A.getNamespaceUri tree
	if T.pack treeNS == ns then Just () else Nothing
	
	treeName <- runMA A.getLocalPart tree
	case treeName of
		"message" -> ReceivedMessage `fmap` parseMessage tree
		"presence" -> ReceivedPresence `fmap` parsePresence tree
		"iq" -> ReceivedIQ `fmap` parseIQ tree
		_ -> Nothing

parseMessage :: XmlTree -> Maybe Message
parseMessage t = do
	typeStr <- runMA (A.getAttrValue "type") t
	msgType <- case typeStr of
		"normal"    -> Just MessageNormal
		"chat"      -> Just MessageChat
		"groupchat" -> Just MessageGroupChat
		"headline"  -> Just MessageHeadline
		"error"     -> Just MessageError
		_           -> Nothing
	msgTo <- xmlJID "to" t
	msgFrom <- xmlJID "from" t
	let msgID = T.pack `fmap` runMA (A.getAttrValue "id") t
	let msgLang = T.pack `fmap` runMA (A.getAttrValue "lang") t
	let payloads = A.runLA (A.getChildren >>> A.isElem) t
	return $ Message msgType msgTo msgFrom msgID msgLang payloads

parsePresence :: XmlTree -> Maybe Presence
parsePresence t = do
	let typeStr = maybe "" id $ runMA (A.getAttrValue "type") t
	pType <- case typeStr of
		""             -> Just PresenceAvailable
		"unavailable"  -> Just PresenceUnavailable
		"subscribe"    -> Just PresenceSubscribe
		"subscribed"   -> Just PresenceSubscribed
		"unsubscribe"  -> Just PresenceUnsubscribe
		"unsubscribed" -> Just PresenceUnsubscribed
		"probe"        -> Just PresenceProbe
		"error"        -> Just PresenceError
		_              -> Nothing
		
	msgTo <- xmlJID "to" t
	msgFrom <- xmlJID "from" t
	let msgID = T.pack `fmap` runMA (A.getAttrValue "id") t
	let msgLang = T.pack `fmap` runMA (A.getAttrValue "lang") t
	let payloads = A.runLA (A.getChildren >>> A.isElem) t
	return $ Presence pType msgTo msgFrom msgID msgLang payloads

parseIQ :: XmlTree -> Maybe IQ
parseIQ t = do
	typeStr <- runMA (A.getAttrValue "type") t
	iqType <- case typeStr of
		"get"    -> Just IQGet
		"set"    -> Just IQSet
		"result" -> Just IQResult
		"error"  -> Just IQError
		_        -> Nothing
	msgTo <- xmlJID "to" t
	msgFrom <- xmlJID "from" t
	let msgID = T.pack `fmap` runMA (A.getAttrValue "id") t
	let msgLang = T.pack `fmap` runMA (A.getAttrValue "lang") t
	payload <- runMA (A.getChildren >>> A.isElem) t
	return $ IQ iqType msgTo msgFrom msgID msgLang payload

xmlJID :: String -> XmlTree -> Maybe (Maybe JID)
xmlJID attr t = case runMA (A.getAttrValue attr) t of
	Nothing -> Just Nothing
	Just raw -> case parseJID (T.pack raw) of
		Just jid -> Just (Just jid)
		Nothing -> Nothing

runMA :: A.LA a b -> a -> Maybe b
runMA arr x = case A.runLA arr x of
	[] -> Nothing
	(y:_) -> Just y

D Network/Protocol/XMPP/Internal/Stream.hs => Network/Protocol/XMPP/Internal/Stream.hs +0 -25
@@ 1,25 0,0 @@
-- 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.Stream
	( Stream (..)
	) where
import qualified Data.Text as T
import Text.XML.HXT.DOM.Interface (XmlTree)

class Stream a where
	streamNamespace :: a -> T.Text
	putTree :: a -> XmlTree -> IO ()
	getTree :: a -> IO XmlTree

M Network/Protocol/XMPP/JID.hs => Network/Protocol/XMPP/JID.hs +3 -7
@@ 16,13 16,9 @@
{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.JID
	( JID (..)
	, Node
	, Domain
	, Resource
	
	, strNode
	, strDomain
	, strResource
	, Node (..)
	, Domain (..)
	, Resource (..)
	
	, parseJID
	, formatJID

M Network/Protocol/XMPP/Stanza.hs => Network/Protocol/XMPP/Stanza.hs +244 -8
@@ 14,13 14,7 @@
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

module Network.Protocol.XMPP.Stanza
	( Stanza
	  ( stanzaTo
	  , stanzaFrom
	  , stanzaID
	  , stanzaLang
	  , stanzaPayloads
	  )
	( Stanza (..)
	
	, ReceivedStanza (..)
	, Message (..)


@@ 33,5 27,247 @@ module Network.Protocol.XMPP.Stanza
	, emptyMessage
	, emptyPresence
	, emptyIQ
	
	, stanzaToTree
	, treeToStanza
	) where
import Network.Protocol.XMPP.Internal.Stanza

import qualified Data.Text as T
import Text.XML.HXT.DOM.Interface (XmlTree)
import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A

import Network.Protocol.XMPP.XML (element)
import Network.Protocol.XMPP.JID (JID, parseJID, formatJID)

class Stanza a where
	stanzaTo       :: a -> Maybe JID
	stanzaFrom     :: a -> Maybe JID
	stanzaID       :: a -> Maybe T.Text
	stanzaLang     :: a -> Maybe T.Text
	stanzaPayloads :: a -> [XmlTree]
	stanzaToTree   :: a -> XmlTree

data ReceivedStanza
	= ReceivedMessage Message
	| ReceivedPresence Presence
	| ReceivedIQ IQ

data Message = Message
	{ messageType     :: MessageType
	, messageTo       :: Maybe JID
	, messageFrom     :: Maybe JID
	, messageID       :: Maybe T.Text
	, messageLang     :: Maybe T.Text
	, messagePayloads :: [XmlTree]
	}

instance Stanza Message where
	stanzaTo = messageTo
	stanzaFrom = messageFrom
	stanzaID = messageID
	stanzaLang = messageLang
	stanzaPayloads = messagePayloads
	stanzaToTree x = stanzaToTree' x "message" typeStr where
		typeStr = case messageType x of
			MessageNormal -> "normal"
			MessageChat -> "chat"
			MessageGroupChat -> "groupchat"
			MessageHeadline -> "headline"
			MessageError -> "error"

data MessageType
	= MessageNormal
	| MessageChat
	| MessageGroupChat
	| MessageHeadline
	| MessageError
	deriving (Show, Eq)

emptyMessage :: MessageType -> Message
emptyMessage t = Message
	{ messageType = t
	, messageTo = Nothing
	, messageFrom = Nothing
	, messageID = Nothing
	, messageLang = Nothing
	, messagePayloads = []
	}

data Presence = Presence
	{ presenceType     :: PresenceType
	, presenceTo       :: Maybe JID
	, presenceFrom     :: Maybe JID
	, presenceID       :: Maybe T.Text
	, presenceLang     :: Maybe T.Text
	, presencePayloads :: [XmlTree]
	}

instance Stanza Presence where
	stanzaTo = presenceTo
	stanzaFrom = presenceFrom
	stanzaID = presenceID
	stanzaLang = presenceLang
	stanzaPayloads = presencePayloads
	stanzaToTree x = stanzaToTree' x "presence" typeStr where
		typeStr = case presenceType x of
			PresenceAvailable -> ""
			PresenceUnavailable -> "unavailable"
			PresenceSubscribe -> "subscribe"
			PresenceSubscribed -> "subscribed"
			PresenceUnsubscribe -> "unsubscribe"
			PresenceUnsubscribed -> "unsubscribed"
			PresenceProbe -> "probe"
			PresenceError -> "error"

data PresenceType
	= PresenceAvailable
	| PresenceUnavailable
	| PresenceSubscribe
	| PresenceSubscribed
	| PresenceUnsubscribe
	| PresenceUnsubscribed
	| PresenceProbe
	| PresenceError
	deriving (Show, Eq)

emptyPresence :: PresenceType -> Presence
emptyPresence t = Presence
	{ presenceType = t
	, presenceTo = Nothing
	, presenceFrom = Nothing
	, presenceID = Nothing
	, presenceLang = Nothing
	, presencePayloads = []
	}

data IQ = IQ
	{ iqType    :: IQType
	, iqTo      :: Maybe JID
	, iqFrom    :: Maybe JID
	, iqID      :: Maybe T.Text
	, iqLang    :: Maybe T.Text
	, iqPayload :: XmlTree
	}

instance Stanza IQ where
	stanzaTo = iqTo
	stanzaFrom = iqFrom
	stanzaID = iqID
	stanzaLang = iqLang
	stanzaPayloads iq = [iqPayload iq]
	stanzaToTree x = stanzaToTree' x "iq" typeStr where
		typeStr = case iqType x of
			IQGet -> "get"
			IQSet -> "set"
			IQResult -> "result"
			IQError -> "error"

data IQType
	= IQGet
	| IQSet
	| IQResult
	| IQError
	deriving (Show, Eq)

emptyIQ :: IQType -> XmlTree -> IQ
emptyIQ t tree = IQ
	{ iqType = t
	, iqTo = Nothing
	, iqFrom = Nothing
	, iqID = Nothing
	, iqLang = Nothing
	, iqPayload = tree
	}

stanzaToTree' :: Stanza a => a -> String -> String -> XmlTree
stanzaToTree' stanza name typeStr = element ("", name) attrs payloads where
	payloads = stanzaPayloads stanza
	attrs = concat
		[ mattr "to" $ fmap formatJID . stanzaTo
		, mattr "from" $ fmap formatJID . stanzaFrom
		, mattr "id" stanzaID
		, mattr "xml:lang" stanzaLang
		, if null typeStr then [] else [("", "type", typeStr)]
		]
	mattr label f = case f stanza of
		Nothing -> []
		Just text -> [("", label, T.unpack text)]

treeToStanza :: T.Text -> XmlTree -> Maybe ReceivedStanza
treeToStanza ns tree = do
	treeNS <- runMA A.getNamespaceUri tree
	if T.pack treeNS == ns then Just () else Nothing
	
	treeName <- runMA A.getLocalPart tree
	case treeName of
		"message" -> ReceivedMessage `fmap` parseMessage tree
		"presence" -> ReceivedPresence `fmap` parsePresence tree
		"iq" -> ReceivedIQ `fmap` parseIQ tree
		_ -> Nothing

parseMessage :: XmlTree -> Maybe Message
parseMessage t = do
	typeStr <- runMA (A.getAttrValue "type") t
	msgType <- case typeStr of
		"normal"    -> Just MessageNormal
		"chat"      -> Just MessageChat
		"groupchat" -> Just MessageGroupChat
		"headline"  -> Just MessageHeadline
		"error"     -> Just MessageError
		_           -> Nothing
	msgTo <- xmlJID "to" t
	msgFrom <- xmlJID "from" t
	let msgID = T.pack `fmap` runMA (A.getAttrValue "id") t
	let msgLang = T.pack `fmap` runMA (A.getAttrValue "lang") t
	let payloads = A.runLA (A.getChildren >>> A.isElem) t
	return $ Message msgType msgTo msgFrom msgID msgLang payloads

parsePresence :: XmlTree -> Maybe Presence
parsePresence t = do
	let typeStr = maybe "" id $ runMA (A.getAttrValue "type") t
	pType <- case typeStr of
		""             -> Just PresenceAvailable
		"unavailable"  -> Just PresenceUnavailable
		"subscribe"    -> Just PresenceSubscribe
		"subscribed"   -> Just PresenceSubscribed
		"unsubscribe"  -> Just PresenceUnsubscribe
		"unsubscribed" -> Just PresenceUnsubscribed
		"probe"        -> Just PresenceProbe
		"error"        -> Just PresenceError
		_              -> Nothing
		
	msgTo <- xmlJID "to" t
	msgFrom <- xmlJID "from" t
	let msgID = T.pack `fmap` runMA (A.getAttrValue "id") t
	let msgLang = T.pack `fmap` runMA (A.getAttrValue "lang") t
	let payloads = A.runLA (A.getChildren >>> A.isElem) t
	return $ Presence pType msgTo msgFrom msgID msgLang payloads

parseIQ :: XmlTree -> Maybe IQ
parseIQ t = do
	typeStr <- runMA (A.getAttrValue "type") t
	iqType <- case typeStr of
		"get"    -> Just IQGet
		"set"    -> Just IQSet
		"result" -> Just IQResult
		"error"  -> Just IQError
		_        -> Nothing
	msgTo <- xmlJID "to" t
	msgFrom <- xmlJID "from" t
	let msgID = T.pack `fmap` runMA (A.getAttrValue "id") t
	let msgLang = T.pack `fmap` runMA (A.getAttrValue "lang") t
	payload <- runMA (A.getChildren >>> A.isElem) t
	return $ IQ iqType msgTo msgFrom msgID msgLang payload

xmlJID :: String -> XmlTree -> Maybe (Maybe JID)
xmlJID attr t = case runMA (A.getAttrValue attr) t of
	Nothing -> Just Nothing
	Just raw -> case parseJID (T.pack raw) of
		Just jid -> Just (Just jid)
		Nothing -> Nothing

runMA :: A.LA a b -> a -> Maybe b
runMA arr x = case A.runLA arr x of
	[] -> Nothing
	(y:_) -> Just y

M Network/Protocol/XMPP/Stream.hs => Network/Protocol/XMPP/Stream.hs +13 -7
@@ 14,15 14,21 @@
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

module Network.Protocol.XMPP.Stream
	( Stream
	( Stream (..)
	, putStanza
	, getStanza
	) where
import Network.Protocol.XMPP.Internal.Stream
import Network.Protocol.XMPP.Internal.Stanza
import qualified Data.Text as T
import Text.XML.HXT.DOM.Interface (XmlTree)
import qualified Network.Protocol.XMPP.Stanza as S

putStanza :: (Stream stream, Stanza stanza) => stream -> stanza -> IO ()
putStanza stream = putTree stream . stanzaToTree
class Stream a where
	streamNamespace :: a -> T.Text
	putTree :: a -> XmlTree -> IO ()
	getTree :: a -> IO XmlTree

getStanza :: Stream stream => stream -> IO (Maybe ReceivedStanza)
getStanza stream = treeToStanza (streamNamespace stream) `fmap` getTree stream
putStanza :: (Stream stream, S.Stanza stanza) => stream -> stanza -> IO ()
putStanza stream = putTree stream . S.stanzaToTree

getStanza :: Stream stream => stream -> IO (Maybe S.ReceivedStanza)
getStanza stream = S.treeToStanza (streamNamespace stream) `fmap` getTree stream

R Network/Protocol/XMPP/Internal/XML.hs => Network/Protocol/XMPP/XML.hs +2 -2
@@ 13,7 13,7 @@
-- 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.XML
module Network.Protocol.XMPP.XML
	( getTree
	, putTree
	, readEventsUntil


@@ 22,7 22,7 @@ module Network.Protocol.XMPP.Internal.XML
	, attr
	, qname
	) where
import qualified Network.Protocol.XMPP.Internal.Handle as H
import qualified Network.Protocol.XMPP.Handle as H
import qualified Data.ByteString.Char8 as C8

-- XML Parsing

M network-protocol-xmpp.cabal => network-protocol-xmpp.cabal +7 -9
@@ 34,17 34,15 @@ library

  exposed-modules:
    Network.Protocol.XMPP

  other-modules:
    Network.Protocol.XMPP.Authentication
    Network.Protocol.XMPP.Client
    Network.Protocol.XMPP.Component
    Network.Protocol.XMPP.Connections
    Network.Protocol.XMPP.Features
    Network.Protocol.XMPP.Handle
    Network.Protocol.XMPP.JID
    Network.Protocol.XMPP.Stanza
    Network.Protocol.XMPP.Stream

  other-modules:
    Network.Protocol.XMPP.Internal.Authentication
    Network.Protocol.XMPP.Internal.Connections
    Network.Protocol.XMPP.Internal.Features
    Network.Protocol.XMPP.Internal.Handle
    Network.Protocol.XMPP.Internal.Stanza
    Network.Protocol.XMPP.Internal.Stream
    Network.Protocol.XMPP.Internal.XML
    Network.Protocol.XMPP.XML