network-protocol-xmpp 0.2.1 → 0.3

raw patch · 18 files changed

+1362/−949 lines, 18 filesdep +failable-listdep +gnuidndep +gnutlsdep −SHAdep −hsgnutlsdep −hxtdep ~bytestringdep ~gsasldep ~libxml-saxPVP ok

version bump matches the API change (PVP)

Dependencies added: failable-list, gnuidn, gnutls, monads-tf, text, transformers, xml-types

Dependencies removed: SHA, hsgnutls, hxt

Dependency ranges changed: bytestring, gsasl, libxml-sax

API changes (from Hackage documentation)

Files

• Network/Protocol/XMPP.hs +69/−23
• Network/Protocol/XMPP/Client.hs +127/−93
• Network/Protocol/XMPP/Client/Authentication.hs +133/−0
• Network/Protocol/XMPP/Client/Features.hs +68/−0
• Network/Protocol/XMPP/Component.hs +78/−67
• Network/Protocol/XMPP/Connection.hs +0/−38
• Network/Protocol/XMPP/Connections.hs +58/−0
• Network/Protocol/XMPP/ErrorT.hs +72/−0
• Network/Protocol/XMPP/Handle.hs +67/−0
• Network/Protocol/XMPP/JID.hs +89/−94
• Network/Protocol/XMPP/Monad.hs +178/−0
• Network/Protocol/XMPP/SASL.hs +0/−101
• Network/Protocol/XMPP/Stanza.hs +274/−0
• Network/Protocol/XMPP/Stanzas.hs +0/−145
• Network/Protocol/XMPP/Stream.hs +0/−276
• Network/Protocol/XMPP/Util.hs +0/−97
• Network/Protocol/XMPP/XML.hs +123/−0
• network-protocol-xmpp.cabal +26/−15

@@ -1,27 +1,73 @@-{- Copyright (C) 2009 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/>.--}+-- 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 (-	 module Network.Protocol.XMPP.JID-	,module Network.Protocol.XMPP.Client-	,module Network.Protocol.XMPP.Component-	,module Network.Protocol.XMPP.Stanzas-	) where -import Network.Protocol.XMPP.JID+module Network.Protocol.XMPP+	( +	-- * 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+	+	-- * The XMPP monad+	, XMPP+	, Server (..)+	, Error (..)+	, runClient+	, runComponent+	, putStanza+	, getStanza+	, bindJID+	+	-- ** Resuming sessions+	, Session+	, getSession+	, runXMPP+	) where import Network.Protocol.XMPP.Client import Network.Protocol.XMPP.Component-import Network.Protocol.XMPP.Stanzas+import Network.Protocol.XMPP.Connections+import Network.Protocol.XMPP.JID+import Network.Protocol.XMPP.Monad+import Network.Protocol.XMPP.Stanza

@@ -1,109 +1,143 @@-{- Copyright (C) 2009 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/>.--}+-- 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.Client (-	 ConnectedClient-	,Client-	,clientConnect-	,clientAuthenticate-	,clientBind-	,clientJID-	,clientServerJID-	,putTree-	,getTree-	,putStanza+{-# LANGUAGE OverloadedStrings #-}+module Network.Protocol.XMPP.Client+	( runClient+	, bindJID 	) where--import Network (HostName, PortID, connectTo)-import Text.XML.HXT.Arrow ((>>>))-import qualified Text.XML.HXT.Arrow as A-import Text.XML.HXT.DOM.TypeDefs (XmlTree)-import qualified Text.XML.HXT.DOM.XmlNode as XN--import Network.Protocol.XMPP.JID (JID, jidParse, jidResource)-import qualified Network.Protocol.XMPP.SASL as SASL-import qualified Network.Protocol.XMPP.Stream as S-import Network.Protocol.XMPP.Util (mkElement, mkQName)-import Network.Protocol.XMPP.Stanzas (Stanza, stanzaToTree)-import Network.Protocol.XMPP.Connection+import Control.Monad ((>=>))+import Control.Monad.Error (throwError)+import Control.Monad.Trans (liftIO)+import Data.ByteString (ByteString)+import qualified Data.Text.Lazy as T+import Network (connectTo)+import qualified System.IO as IO -data ConnectedClient = ConnectedClient JID S.Stream+import qualified Network.Protocol.XMPP.Client.Authentication as A+import qualified Network.Protocol.XMPP.Connections as C+import qualified Network.Protocol.XMPP.Client.Features as F+import qualified Network.Protocol.XMPP.Handle as H+import qualified Network.Protocol.XMPP.JID as J+import qualified Network.Protocol.XMPP.Monad as M+import qualified Network.Protocol.XMPP.XML as X+import Network.Protocol.XMPP.ErrorT+import Network.Protocol.XMPP.Stanza -data Client = Client {-	 clientJID        :: JID-	,clientServerJID  :: JID-	,clientStream     :: S.Stream-	}+runClient :: C.Server+          -> J.JID -- ^ Client JID+          -> T.Text -- ^ Username+          -> T.Text -- ^ Password+          -> M.XMPP a+          -> IO (Either M.Error a)+runClient server jid username password xmpp = do+	-- Open a TCP connection+	let C.Server sjid host port = server+	rawHandle <- connectTo host port+	IO.hSetBuffering rawHandle IO.NoBuffering+	let handle = H.PlainHandle rawHandle+	+	-- Open the initial stream and authenticate+	M.startXMPP handle "jabber:client" $ do+		features <- newStream sjid+		tryTLS sjid features $ \tlsFeatures -> do+			let mechanisms = authenticationMechanisms tlsFeatures+			A.authenticate mechanisms jid sjid username password+			M.restartXMPP Nothing (newStream sjid >> xmpp) -type Username = String-type Password = String+newStream :: J.JID -> M.XMPP [F.Feature]+newStream jid = do+	M.putBytes $ C.xmlHeader "jabber:client" jid+	M.readEvents C.startOfStream+	F.parseFeatures `fmap` M.getElement -clientConnect :: JID -> HostName -> PortID -> IO ConnectedClient-clientConnect jid host port = do-	handle <- connectTo host port-	stream <- S.beginStream jid "jabber:client" handle-	return $ ConnectedClient jid stream+tryTLS :: J.JID -> [F.Feature] -> ([F.Feature] -> M.XMPP a) -> M.XMPP a+tryTLS sjid features m+	| not (streamSupportsTLS features) = m features+	| otherwise = do+		M.putElement xmlStartTLS+		M.getElement+		h <- M.getHandle+		eitherTLS <- liftIO $ runErrorT $ H.startTLS h+		case eitherTLS of+			Left err -> throwError $ M.TransportError err+			Right tls -> M.restartXMPP (Just tls) $ newStream sjid >>= m -clientAuthenticate :: ConnectedClient -> JID -> Username -> Password -> IO Client-clientAuthenticate (ConnectedClient serverJID stream) jid username password = do-	authed <- SASL.authenticate stream jid serverJID username password-	case authed of-		SASL.Failure -> error "Authentication failure"-		_ -> do-			newStream <- S.restartStream stream-			return $ Client jid serverJID newStream+authenticationMechanisms :: [F.Feature] -> [ByteString]+authenticationMechanisms = step where+	step [] = []+	step (f:fs) = case f of+		(F.FeatureSASL ms) -> ms+		_ -> step fs -clientBind :: Client -> IO JID-clientBind c = do+-- | Send a @\<bind\>@ message for the given 'J.JID', returning the server's reply. In+-- most cases the reply will be the same as the input. However, if the input has no+-- 'J.Resource', the returned 'J.JID' will contain a generated 'J.Resource'.+-- +-- Clients must bind a 'J.JID' before sending any 'Stanza's.+bindJID :: J.JID -> M.XMPP J.JID+bindJID jid = do 	-- Bind-	let resourceElements = case jidResource . clientJID $ c of-		"" -> []-		resource ->-			[mkElement ("", "resource")-				[]-				[XN.mkText resource]]+	M.putStanza . bindStanza . J.jidResource $ jid+	bindResult <- M.getStanza+	let getJID =+		X.elementChildren+		>=> X.isNamed (X.Name "jid" (Just "urn:ietf:params:xml:ns:xmpp-bind") Nothing)+		>=> X.elementNodes+		>=> X.isContent+		>=> return . X.contentText 	-	putTree c $ mkElement ("", "iq")-		[("", "type", "set")]-		[mkElement ("", "bind")-		 	[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-bind")]-		 	resourceElements]+	let maybeJID = do+		iq <- case bindResult of+			ReceivedIQ x -> Just x+			_ -> Nothing+		payload <- iqPayload iq+		+		case getJID payload of+			[] -> Nothing+			(str:_) -> J.parseJID str 	-	bindResult <- getTree c-	let [rawJID] = A.runLA (-		A.deep (A.hasQName (mkQName "urn:ietf:params:xml:ns:xmpp-bind" "jid"))-		>>> A.getChildren-		>>> A.getText) bindResult-	let jid = case jidParse rawJID of-		Just x -> x-		_ -> error "Couldn't parse server's returned JID"+	returnedJID <- case maybeJID of+		Just x -> return x+		Nothing -> throwError $ M.InvalidBindResult bindResult 	 	-- Session-	putTree c $ mkElement ("", "iq")-		[("", "type", "set")]-		[mkElement ("", "session")-			[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-session")]-			[]]+	M.putStanza sessionStanza+	M.getStanza 	-	getTree c+	M.putStanza $ emptyPresence PresenceAvailable+	M.getStanza 	-	putTree c $ mkElement ("", "presence") [] []-	getTree c-	return jid+	return returnedJID -instance Connection Client where-	getTree = S.getTree . clientStream-	putTree = S.putTree . clientStream+bindStanza :: Maybe J.Resource -> IQ+bindStanza resource = (emptyIQ IQSet) { iqPayload = Just payload } where+	payload = X.nselement "urn:ietf:params:xml:ns:xmpp-bind" "bind" [] requested+	requested = case fmap J.strResource resource of+		Nothing -> []+		Just x -> [X.NodeElement $ X.element "resource" []+			[X.NodeContent $ X.ContentText x]]++sessionStanza :: IQ+sessionStanza = (emptyIQ IQSet) { iqPayload = Just payload } where+	payload = X.nselement "urn:ietf:params:xml:ns:xmpp-session" "session" [] []++streamSupportsTLS :: [F.Feature] -> Bool+streamSupportsTLS = any isStartTLS where+	isStartTLS (F.FeatureStartTLS _) = True+	isStartTLS _                     = False++xmlStartTLS :: X.Element+xmlStartTLS = X.nselement "urn:ietf:params:xml:ns:xmpp-tls" "starttls" [] []

@@ -0,0 +1,133 @@+-- Copyright (C) 2009-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 #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Network.Protocol.XMPP.Client.Authentication+	( Result (..)+	, authenticate+	) where+import qualified Control.Exception as Exc+import Control.Monad (when, (>=>))+import Control.Monad.IO.Class (MonadIO, liftIO)+import qualified Control.Monad.Error as E+import qualified Data.ByteString.Char8 as B+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Lazy as TL+import Data.Typeable (Typeable)+import qualified Network.Protocol.SASL.GNU as SASL++import qualified Network.Protocol.XMPP.Monad as M+import qualified Network.Protocol.XMPP.XML as X+import Network.Protocol.XMPP.JID (JID, formatJID, jidResource)++data Result = Success | Failure+	deriving (Show, Eq)++data AuthException = XmppError M.Error | SaslError TL.Text+	deriving (Typeable, Show)++instance Exc.Exception AuthException++authenticate :: [B.ByteString] -- ^ Mechanisms+             -> JID -- ^ User JID+             -> JID -- ^ Server JID+             -> TL.Text -- ^ Username+             -> TL.Text -- ^ Password+             -> M.XMPP ()+authenticate xmppMechanisms userJID serverJID username password = xmpp where+	mechanisms = map SASL.Mechanism xmppMechanisms+	authz = formatJID $ userJID { jidResource = Nothing }+	hostname = formatJID serverJID+	utf8 = TE.encodeUtf8 . T.concat . TL.toChunks+	+	xmpp = do+		ctx <- M.getSession+		res <- liftIO $ Exc.try $ SASL.runSASL $ do+			suggested <- SASL.clientSuggestMechanism mechanisms+			case suggested of+				Nothing -> saslError "No supported authentication mechanism"+				Just mechanism -> authSasl ctx mechanism+		case res of+			Right Success -> return ()+			Right Failure -> E.throwError M.AuthenticationFailure+			Left (XmppError err) -> E.throwError err+			Left (SaslError err) -> E.throwError $ M.AuthenticationError err+	+	authSasl ctx mechanism = do+		let (SASL.Mechanism mechBytes) = mechanism+		sessionResult <- SASL.runClient mechanism $ do+			SASL.setProperty SASL.PropertyAuthzID $ utf8 authz+			SASL.setProperty SASL.PropertyAuthID $ utf8 username+			SASL.setProperty SASL.PropertyPassword $ utf8 password+			SASL.setProperty SASL.PropertyService $ B.pack "xmpp"+			SASL.setProperty SASL.PropertyHostname $ utf8 hostname+			+			(b64text, rc) <- SASL.step64 $ B.pack ""+			putElement ctx $ X.nselement "urn:ietf:params:xml:ns:xmpp-sasl" "auth"+				[("mechanism", TL.pack $ B.unpack mechBytes)]+				[X.NodeContent $ X.ContentText $ TL.pack $ B.unpack b64text]+			+			case rc of+				SASL.Complete -> saslFinish ctx+				SASL.NeedsMore -> saslLoop ctx+			+		case sessionResult of+			Right x -> return x+			Left err -> saslError $ TL.pack $ show err++saslLoop :: M.Session -> SASL.Session Result+saslLoop ctx = do+	elemt <- getElement ctx+	let name = X.Name "challenge" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing+	let getChallengeText =+		X.isNamed name+		>=> X.elementNodes+		>=> X.isContent+		>=> return . X.contentText+	let challengeText = getChallengeText elemt+	when (null challengeText) $ saslError "Received empty challenge"+	+	(b64text, rc) <- SASL.step64 . B.pack . concatMap TL.unpack $ challengeText+	putElement ctx $ X.nselement "urn:ietf:params:xml:ns:xmpp-sasl" "response"+		[] [X.NodeContent $ X.ContentText $ TL.pack $ B.unpack b64text]+	case rc of+		SASL.Complete -> saslFinish ctx+		SASL.NeedsMore -> saslLoop ctx++saslFinish :: M.Session -> SASL.Session Result+saslFinish ctx = do+	elemt <- getElement ctx+	let name = X.Name "success" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing+	let success = X.isNamed name elemt+	return $ if null success then Failure else Success++putElement :: M.Session -> X.Element -> SASL.Session ()+putElement ctx elemt = liftIO $ do+	res <- M.runXMPP ctx $ M.putElement elemt+	case res of+		Left err -> Exc.throwIO $ XmppError err+		Right x -> return x++getElement :: M.Session -> SASL.Session X.Element+getElement ctx = liftIO $ do+	res <- M.runXMPP ctx M.getElement+	case res of+		Left err -> Exc.throwIO $ XmppError err+		Right x -> return x++saslError :: MonadIO m => TL.Text -> m a+saslError = liftIO . Exc.throwIO . SaslError

@@ -0,0 +1,68 @@+-- 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.Client.Features+	( Feature (..)+	, parseFeatures+	, parseFeature+	) where+import Control.Arrow ((&&&))+import qualified Data.ByteString.Char8 as B+import qualified Data.Text.Lazy as TL+import qualified Network.Protocol.XMPP.XML as X++data Feature =+	  FeatureStartTLS Bool+	| FeatureSASL [B.ByteString]+	| FeatureRegister+	| FeatureBind+	| FeatureSession+	| FeatureUnknown X.Element+	deriving (Show, Eq)++parseFeatures :: X.Element -> [Feature]+parseFeatures e =+	X.isNamed nameFeatures e+	>>= X.elementChildren+	>>= return . parseFeature++parseFeature :: X.Element -> Feature+parseFeature elemt = feature where+	unpackName = (maybe "" id . X.nameNamespace) &&& X.nameLocalName+	feature = case unpackName (X.elementName elemt) of+		("urn:ietf:params:xml:ns:xmpp-tls", "starttls") -> parseFeatureTLS elemt+		("urn:ietf:params:xml:ns:xmpp-sasl", "mechanisms") -> parseFeatureSASL elemt+		("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 elemt++parseFeatureTLS :: X.Element -> Feature+parseFeatureTLS _ = FeatureStartTLS True -- TODO: detect whether or not required++parseFeatureSASL :: X.Element -> Feature+parseFeatureSASL e = FeatureSASL $+	X.elementChildren e+	>>= X.isNamed nameMechanism+	>>= X.elementNodes+	>>= X.isContent+	>>= return . B.pack . TL.unpack . X.contentText++nameMechanism :: X.Name+nameMechanism = X.Name "mechanism" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing++nameFeatures :: X.Name+nameFeatures = X.Name "features" (Just "http://etherx.jabber.org/streams") Nothing

@@ -1,77 +1,88 @@-{- Copyright (C) 2010 Stephan Maka <stephan@spaceboyz.net>-   -   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/>.--}-+-- Copyright (C) 2010 Stephan Maka <stephan@spaceboyz.net>+-- 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.Component (-	 ConnectedComponent-	,Component-	,componentConnect-	,componentAuthenticate-	,componentJID+{-# LANGUAGE OverloadedStrings #-}+module Network.Protocol.XMPP.Component+	( runComponent 	) where- import Control.Monad (when)-import Network (HostName, PortID, connectTo)-import Text.XML.HXT.Arrow ((>>>))-import qualified Text.XML.HXT.Arrow as A-import Text.XML.HXT.DOM.TypeDefs (XmlTree)-import qualified Text.XML.HXT.DOM.XmlNode as XN-import qualified Data.Digest.Pure.SHA as SHA--import Network.Protocol.XMPP.JID (JID, jidParse, jidResource)-import qualified Network.Protocol.XMPP.SASL as SASL-import qualified Network.Protocol.XMPP.Stream as S-import Network.Protocol.XMPP.Util (mkElement, mkQName)-import Network.Protocol.XMPP.Stanzas (Stanza, stanzaToTree)-import Network.Protocol.XMPP.Connection-import qualified Data.ByteString.Lazy.Char8 as B (pack)--data ConnectedComponent = ConnectedComponent JID S.Stream--data Component = Component {-	 componentJID :: JID-	,componentStream :: S.Stream-	}--type Password = String+import Control.Monad.Error (throwError)+import Data.Bits (shiftR, (.&.))+import Data.Char (intToDigit)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.Encoding as TE+import Network (connectTo)+import Network.Protocol.SASL.GNU (sha1)+import qualified System.IO as IO+import qualified Text.XML.LibXML.SAX as SAX -componentConnect :: JID -> HostName -> PortID -> IO ConnectedComponent-componentConnect jid host port = do-	handle <- connectTo host port-	stream <- S.beginStream jid "jabber:component:accept" handle-	return $ ConnectedComponent jid stream+import qualified Network.Protocol.XMPP.Connections as C+import qualified Network.Protocol.XMPP.Handle as H+import qualified Network.Protocol.XMPP.Monad as M+import qualified Network.Protocol.XMPP.XML as X+import Network.Protocol.XMPP.JID (JID) -componentAuthenticate :: ConnectedComponent -> Password -> IO Component-componentAuthenticate (ConnectedComponent jid stream) password-    = do let c = Component jid stream+runComponent :: C.Server+             -> T.Text -- ^ Server secret+             -> M.XMPP a+             -> IO (Either M.Error a)+runComponent server password xmpp = do+	let C.Server jid host port = server+	rawHandle <- connectTo host port+	IO.hSetBuffering rawHandle IO.NoBuffering+	let handle = H.PlainHandle rawHandle+	M.startXMPP handle "jabber:component:accept" $ do+		streamID <- beginStream jid+		authenticate streamID password+		xmpp -         let S.XMPPStreamID sid = S.streamID stream-             hash = SHA.showDigest . SHA.sha1 . B.pack $ sid ++ password-         putTree c $ mkElement ("", "handshake") [] [XN.mkText hash]+beginStream :: JID -> M.XMPP T.Text+beginStream jid = do+	M.putBytes $ C.xmlHeader "jabber:component:accept" jid+	events <- M.readEvents C.startOfStream+	case parseStreamID $ last events of+		Nothing -> throwError M.NoComponentStreamID+		Just x -> return x -         result <- getTree c-         when (A.runLA (A.getChildren-                        >>> A.hasQName (mkQName "jabber:component:accept" "handshake")-                       ) result == []) $-             error "Component handshake failed"+parseStreamID :: SAX.Event -> Maybe T.Text+parseStreamID (SAX.BeginElement _ attrs) = sid where+	sid = case idAttrs of+		(x:_) -> Just . X.attributeText $ x+		_ -> Nothing+	idAttrs = filter (matchingName . X.attributeName) attrs+	matchingName = (== X.Name "jid" (Just "jabber:component:accept") Nothing)+parseStreamID _ = Nothing -         return c+authenticate :: T.Text -> T.Text -> M.XMPP ()+authenticate streamID password = do+	let bytes = buildSecret streamID password+	let digest = showDigest $ sha1 bytes+	M.putElement $ X.element "handshake" [] [X.NodeContent $ X.ContentText digest]+	result <- M.getElement+	let nameHandshake = X.Name "handshake" (Just "jabber:component:accept") Nothing+	when (null (X.isNamed nameHandshake result)) $+		throwError M.AuthenticationFailure --------------------------------------------------------------------------------+buildSecret :: T.Text -> T.Text -> B.ByteString+buildSecret sid password = B.concat . BL.toChunks $ bytes where+	bytes = TE.encodeUtf8 $ X.escape $ T.append sid password -instance Connection Component where-    getTree = S.getTree . componentStream-    putTree = S.putTree . componentStream+showDigest :: B.ByteString -> T.Text+showDigest = T.pack . concatMap wordToHex . B.unpack where+	wordToHex x = [hexDig $ shiftR x 4, hexDig $ x .&. 0xF]+	hexDig = intToDigit . fromIntegral

@@ -1,38 +0,0 @@-{- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>-                      Stephan Maka <stephan@spaceboyz.net>-   -   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.Connection-	( Connection-	, getTree-	, putTree-	, putStanza-	) where--import Text.XML.HXT.DOM.TypeDefs (XmlTree)-import Network.Protocol.XMPP.Stanzas (Stanza, stanzaToTree)---- |Provides the basic operations for XMPP connections.-class Connection c where-	-- |Receive XML-	getTree :: c -> IO XmlTree-	-	-- |Send XML-	putTree :: c -> XmlTree -> IO ()-	-	-- |Send a stanza, uses putTree by default-	putStanza :: c -> Stanza -> IO ()-	putStanza c = putTree c . stanzaToTree

@@ -0,0 +1,58 @@+-- 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.Connections+	( Server (..)+	, xmlHeader+	, startOfStream+	, qnameStream+	) where+import Network (HostName, PortID)+import qualified Data.ByteString.Lazy as B+import qualified Data.Text.Lazy as T+import Data.Text.Lazy.Encoding (encodeUtf8)+import qualified Text.XML.LibXML.SAX as SAX++import qualified Network.Protocol.XMPP.XML as X+import Network.Protocol.XMPP.JID (JID, formatJID)++data Server = Server+	{ serverJID      :: JID+	, serverHostname :: HostName+	, serverPort     :: PortID+	}++-- Since only the opening tag should be written, normal XML+-- serialization cannot be used. Be careful to escape any embedded+-- attributes.+xmlHeader :: T.Text -> JID -> B.ByteString+xmlHeader ns jid = encodeUtf8 header where+	attr x = T.concat ["\"", X.escape x, "\""]+	header = T.concat+		[ "<?xml version='1.0'?>\n"+		, "<stream:stream xmlns=" , attr ns+		, " to=", attr (formatJID jid)+		, " version=\"1.0\""+		, " xmlns:stream=\"http://etherx.jabber.org/streams\">"+		]++startOfStream :: Integer -> SAX.Event -> Bool+startOfStream depth event = case (depth, event) of+	(1, (SAX.BeginElement elemName _)) -> qnameStream == elemName+	_ -> False++qnameStream :: X.Name+qnameStream = X.Name "stream" (Just "http://etherx.jabber.org/streams") Nothing

@@ -0,0 +1,72 @@+-- 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 TypeFamilies #-}+module Network.Protocol.XMPP.ErrorT+	( ErrorT (..)+	, mapErrorT+	) where++import Control.Monad (liftM)+import Control.Monad.Fix (MonadFix, mfix)+import Control.Monad.Trans (MonadIO, liftIO)+import Control.Monad.Trans.Class (MonadTrans, lift)+import qualified Control.Monad.Error as E+import qualified Control.Monad.Reader as R++-- A custom version of ErrorT, without the 'Error' class restriction.++newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }++instance Functor m => Functor (ErrorT e m) where+	fmap f = ErrorT . fmap (fmap f) . runErrorT++instance Monad m => Monad (ErrorT e m) where+	return = ErrorT . return . Right+	(>>=) m k = ErrorT $ do+		x <- runErrorT m+		case x of+			Left l -> return $ Left l+			Right r -> runErrorT $ k r++instance Monad m => E.MonadError (ErrorT e m) where+	type E.ErrorType (ErrorT e m) = e+	throwError = ErrorT . return . Left+	catchError m h = ErrorT $ do+		x <- runErrorT m+		case x of+			Left l -> runErrorT $ h l+			Right r -> return $ Right r++instance MonadTrans (ErrorT e) where+	lift = ErrorT . liftM Right++instance R.MonadReader m => R.MonadReader (ErrorT e m) where+	type R.EnvType (ErrorT e m) = R.EnvType m+	ask = lift R.ask+	local = mapErrorT . R.local++instance MonadIO m => MonadIO (ErrorT e m) where+	liftIO = lift . liftIO++instance MonadFix m => MonadFix (ErrorT e m) where+	mfix f = ErrorT $ mfix $ \ex -> runErrorT $ f $ case ex of+		Right x -> x+		_        -> error "empty mfix parameter"++mapErrorT :: (m (Either e a) -> n (Either e' b))+           -> ErrorT e m a+           -> ErrorT e' n b+mapErrorT f m = ErrorT $ f (runErrorT m)

@@ -0,0 +1,67 @@+-- 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.Handle+	( Handle (..)+	, startTLS+	, hPutBytes+	, hGetBytes+	) where++import Control.Monad (when)+import qualified Control.Monad.Error as E+import Control.Monad.Trans (liftIO)+import qualified Data.ByteString.Lazy as B+import qualified Data.Text.Lazy as T+import qualified System.IO as IO+import qualified Network.Protocol.TLS.GNU as TLS+import Network.Protocol.XMPP.ErrorT++data Handle =+	  PlainHandle IO.Handle+	| SecureHandle IO.Handle TLS.Session++liftTLS :: TLS.Session -> TLS.TLS a -> ErrorT T.Text IO a+liftTLS s = liftTLS' . TLS.runTLS s++liftTLS' :: IO (Either TLS.Error a) -> ErrorT T.Text IO a+liftTLS' io = do+	eitherX <- liftIO io+	case eitherX of+		Left err -> E.throwError $ T.pack $ show err+		Right x -> return x++startTLS :: Handle -> ErrorT T.Text IO Handle+startTLS (SecureHandle _ _) = E.throwError "Can't start TLS on a secure handle"+startTLS (PlainHandle h) = liftTLS' $ TLS.runClient (TLS.handleTransport h) $ do+	TLS.setPriority [TLS.X509]+	TLS.setCredentials =<< TLS.certificateCredentials+	TLS.handshake+	SecureHandle h `fmap` TLS.getSession++hPutBytes :: Handle -> B.ByteString -> ErrorT T.Text IO ()+hPutBytes (PlainHandle h)  = liftIO . B.hPut h+hPutBytes (SecureHandle _ s) = liftTLS s . TLS.putBytes++hGetBytes :: Handle -> Integer -> ErrorT T.Text IO B.ByteString+hGetBytes (PlainHandle h) n = liftIO $  B.hGet h $ fromInteger n+hGetBytes (SecureHandle h s) n = liftTLS s $ do+	pending <- TLS.checkPending+	when (pending == 0) $ do+		liftIO $ IO.hWaitForInput h (- 1)+		return ()+	+	TLS.getBytes n

@@ -1,111 +1,106 @@-{- Copyright (C) 2009 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/>.--}+-- 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.JID (-	 JID(..)-	,JIDNode-	,JIDDomain-	,JIDResource-	-	,jidNodeStr-	,jidDomainStr-	,jidResourceStr-	-	,mkJIDNode-	,mkJIDDomain-	,mkJIDResource-	,mkJID-	-	,jidNode-	,jidDomain-	,jidResource+{-# LANGUAGE OverloadedStrings #-}+module Network.Protocol.XMPP.JID+	( JID (..)+	, Node (..)+	, Domain (..)+	, Resource (..) 	-	,jidParse-	,jidFormat+	, parseJID+	, parseJID_+	, formatJID 	) where--data JID = JID (Maybe JIDNode) JIDDomain (Maybe JIDResource)-	deriving (Eq, Show)--newtype JIDNode = JIDNode String-	deriving (Eq, Show)-	-newtype JIDDomain = JIDDomain String-	deriving (Eq, Show)-	-newtype JIDResource = JIDResource String-	deriving (Eq, Show)+import qualified Data.Text.Lazy as T+import qualified Data.Text.IDN.StringPrep as SP+import Data.String (IsString, fromString) -jidNodeStr :: JIDNode -> String-jidNodeStr (JIDNode s) = s+newtype Node = Node { strNode :: T.Text }+newtype Domain = Domain { strDomain :: T.Text }+newtype Resource = Resource { strResource :: T.Text } -jidDomainStr :: JIDDomain -> String-jidDomainStr (JIDDomain s) = s+instance Show Node where+	showsPrec d (Node x) = showParen (d > 10) $+		showString "Node " . shows x -jidResourceStr :: JIDResource -> String-jidResourceStr (JIDResource s) = s+instance Show Domain where+	showsPrec d (Domain x) = showParen (d > 10) $+		showString "Domain " . shows x -mkJIDNode :: String -> Maybe JIDNode-mkJIDNode "" = Nothing-mkJIDNode s = Just (JIDNode s) -- TODO: stringprep, validation+instance Show Resource where+	showsPrec d (Resource x) = showParen (d > 10) $+		showString "Resource " . shows x -mkJIDDomain :: String -> Maybe JIDDomain-mkJIDDomain "" = Nothing-mkJIDDomain s = Just (JIDDomain s) -- TODO: stringprep, validation+instance Eq Node where+	(==) = equaling strNode -mkJIDResource :: String -> Maybe JIDResource-mkJIDResource "" = Nothing-mkJIDResource s = Just (JIDResource s) -- TODO: stringprep, validation+instance Eq Domain where+	(==) = equaling strDomain -mkJID :: String -> String -> String -> Maybe JID-mkJID nodeStr domainStr resourceStr = let-	node = mkJIDNode nodeStr-	resource = mkJIDResource resourceStr-	in do-		domain <- mkJIDDomain domainStr-		Just (JID node domain resource)+instance Eq Resource where+	(==) = equaling strResource -jidNode :: JID -> String-jidNode (JID x _ _) = maybe "" jidNodeStr x+data JID = JID+	{ jidNode :: Maybe Node+	, jidDomain :: Domain+	, jidResource :: Maybe Resource+	}+	deriving (Eq) -jidDomain :: JID -> String-jidDomain (JID _ x _) = jidDomainStr x+instance Show JID where+	showsPrec d jid =  showParen (d > 10) $+		showString "JID " . shows (formatJID jid) -jidResource :: JID -> String-jidResource (JID _ _ x) = maybe "" jidResourceStr x+instance IsString JID where+	fromString = parseJID_ . fromString --- TODO: validate input according to RFC 3920, section 3.1-jidParse :: String -> Maybe JID-jidParse s = let-	(nodeStr, postNode) = if '@' `elem` s then split s '@' else ("", s)-	(domainStr, resourceStr) = if '/' `elem` postNode then split postNode '/' else (postNode, "")-	in mkJID nodeStr domainStr resourceStr+parseJID :: T.Text -> Maybe JID+parseJID str = maybeJID where+	(node, postNode) = case T.spanBy (/= '@') str of+		(x, y) -> if T.null y+			then ("", x)+			else (x, T.drop 1 y)+	(domain, resource) = case T.spanBy (/= '/') postNode of+		(x, y) -> if T.null y+			then (x, "")+			else (x, T.drop 1 y)+	nullable x f = if T.null x then Just Nothing else fmap Just $ f x+	maybeJID = do+		preppedNode <- nullable node $ stringprepM SP.profileNodeprep+		preppedDomain <- stringprepM SP.profileNameprep domain+		preppedResource <- nullable resource $ stringprepM SP.profileResourceprep+		return $ JID+			(fmap Node preppedNode)+			(Domain preppedDomain)+			(fmap Resource preppedResource)+	stringprepM p x = case SP.stringprep p SP.defaultFlags x of+		Left _ -> Nothing+		Right y -> Just y -jidFormat :: JID -> String-jidFormat (JID node (JIDDomain domain) resource) = let-	nodeStr = maybe "" (\(JIDNode s) -> s ++ "@") node-	resourceStr = maybe "" (\(JIDResource s) -> "/" ++ s) resource-	in concat [nodeStr, domain, resourceStr]+parseJID_ :: T.Text -> JID+parseJID_ text = case parseJID text of+	Just jid -> jid+	Nothing -> error "Malformed JID" -split :: (Eq a) => [a] -> a -> ([a], [a])-split xs final = let-	(before, rawAfter) = span (/= final) xs-	after = safeTail rawAfter-	in (before, after)+formatJID :: JID -> T.Text+formatJID (JID node (Domain domain) resource) = formatted where+	formatted = T.concat [node', domain, resource']+	node' = maybe "" (\(Node x) -> T.append x "@") node+	resource' = maybe "" (\(Resource x) -> T.append "/" x) resource -safeTail :: [a] -> [a]-safeTail [] = []-safeTail (_:xs) = xs+-- Similar to 'comparing'+equaling :: Eq a => (b -> a) -> b -> b -> Bool+equaling f x y = f x == f y

@@ -0,0 +1,178 @@+-- 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 TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.Protocol.XMPP.Monad+	( XMPP (..)+	, Error (..)+	, Session (..)+	, runXMPP+	, startXMPP+	, restartXMPP+	+	, getHandle+	, getSession+	+	, readEvents+	, getElement+	, getStanza+	+	, putBytes+	, putElement+	, putStanza+	) where+import qualified Control.Applicative as A+import Control.Monad (ap)+import Control.Monad.Fix (MonadFix, mfix)+import Control.Monad.Trans (MonadIO, liftIO)+import qualified Control.Monad.Error as E+import qualified Control.Monad.Reader as R+import qualified Data.ByteString.Lazy.Char8 as B+import Data.Text.Lazy (Text)+import Data.Text.Lazy.Encoding (encodeUtf8)+import qualified Data.FailableList as FL+import qualified Text.XML.LibXML.SAX as SAX++import Network.Protocol.XMPP.ErrorT+import qualified Network.Protocol.XMPP.Handle as H+import qualified Network.Protocol.XMPP.Stanza as S+import qualified Network.Protocol.XMPP.XML as X++data Error+	-- | The remote host refused the specified authentication credentials.+	= AuthenticationFailure+	+	-- | There was an error while authenticating with the remote host.+	| AuthenticationError Text+	+	-- | An unrecognized or malformed 'S.Stanza' was received from the remote+	-- host.+	| InvalidStanza X.Element+	+	-- | The remote host sent an invalid reply to a resource bind request.+	| InvalidBindResult S.ReceivedStanza+	+	-- | There was an error with the underlying transport.+	| TransportError Text+	+	-- | The remote host did not send a stream ID when accepting a component+	-- connection.+	| NoComponentStreamID+	deriving (Show)++data Session = Session H.Handle Text SAX.Parser++newtype XMPP a = XMPP { unXMPP :: ErrorT Error (R.ReaderT Session IO) a }++instance Functor XMPP where+	fmap f = XMPP . fmap f . unXMPP++instance Monad XMPP where+	return = XMPP . return+	m >>= f = XMPP $ unXMPP m >>= unXMPP . f++instance MonadIO XMPP where+	liftIO = XMPP . liftIO++instance E.MonadError XMPP where+	type E.ErrorType XMPP = Error+	throwError = XMPP . E.throwError+	catchError m h = XMPP $ E.catchError (unXMPP m) (unXMPP . h)++instance A.Applicative XMPP where+	pure = return+	(<*>) = ap++instance MonadFix XMPP where+	mfix f = XMPP $ mfix $ unXMPP . f++runXMPP :: Session -> XMPP a -> IO (Either Error a)+runXMPP s xmpp = R.runReaderT (runErrorT (unXMPP xmpp)) s++startXMPP :: H.Handle -> Text -> XMPP a -> IO (Either Error a)+startXMPP h ns xmpp = do+	sax <- SAX.newParser+	runXMPP (Session h ns sax) xmpp++restartXMPP :: Maybe H.Handle -> XMPP a -> XMPP a+restartXMPP newH xmpp = do+	Session oldH ns _ <- getSession+	sax <- liftIO SAX.newParser+	let s = Session (maybe oldH id newH) ns sax+	XMPP $ R.local (const s) (unXMPP xmpp)++getSession :: XMPP Session+getSession = XMPP R.ask++getHandle :: XMPP H.Handle+getHandle = do+	Session h _ _ <- getSession+	return h++liftTLS :: ErrorT Text IO a -> XMPP a+liftTLS io = do+	res <- liftIO $ runErrorT io+	case res of+		Left err -> E.throwError $ TransportError err+		Right x -> return x++putBytes :: B.ByteString -> XMPP ()+putBytes bytes = do+	h <- getHandle+	liftTLS $ H.hPutBytes h bytes++putElement :: X.Element -> XMPP ()+putElement = putBytes . encodeUtf8 . X.serialiseElement++putStanza :: S.Stanza a => a -> XMPP ()+putStanza = putElement . S.stanzaToElement++readEvents :: (Integer -> SAX.Event -> Bool) -> XMPP [SAX.Event]+readEvents done = xmpp where+	xmpp = do+		Session h _ p <- getSession+		let nextEvents = do+			-- TODO: read in larger increments+			bytes <- liftTLS $ H.hGetBytes h 1+			failable <- liftIO $ SAX.parse p bytes False+			failableToList failable+		X.readEvents done nextEvents+	+	failableToList f = case f of+		FL.Fail (SAX.Error e) -> E.throwError $ TransportError e+		FL.Done -> return []+		FL.Next e es -> do+			es' <- failableToList es+			return $ e : es'++getElement :: XMPP X.Element+getElement = xmpp where+	xmpp = do+		events <- readEvents endOfTree+		case X.eventsToElement events of+			Just x -> return x+			Nothing -> E.throwError $ TransportError "getElement: invalid event list"+	+	endOfTree 0 (SAX.EndElement _) = True+	endOfTree _ _ = False++getStanza :: XMPP S.ReceivedStanza+getStanza = do+	elemt <- getElement+	Session _ ns _ <- getSession+	case S.elementToStanza ns elemt of+		Just x -> return x+		Nothing -> E.throwError $ InvalidStanza elemt

@@ -1,101 +0,0 @@-{- Copyright (C) 2009 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.SASL (-	 Result(..)-	,authenticate-	) where--import Text.XML.HXT.Arrow ((>>>))-import qualified Text.XML.HXT.Arrow as A-import qualified Text.XML.HXT.DOM.XmlNode as XN-import qualified Network.Protocol.SASL.GSASL as G--import Network.Protocol.XMPP.JID (JID, jidFormat)-import Network.Protocol.XMPP.Util (mkElement, mkQName)-import qualified Network.Protocol.XMPP.Stream as S--type Username = String-type Password = String-type Mechanism = String--data Result = Success | Failure-	deriving (Show, Eq)--authenticate :: S.Stream -> JID -> JID -> Username -> Password -> IO Result-authenticate stream userJID serverJID username password = do-	let mechanisms = (advertisedMechanisms . S.streamFeatures) stream-	let authz = jidFormat userJID-	let hostname = jidFormat serverJID-	-	G.withContext $ \ctxt -> do-	-	suggested <- G.clientSuggestMechanism ctxt mechanisms-	mechanism <- case suggested of-		Just m -> return m-		Nothing -> error "No supported SASL mechanisms advertised"-	-	G.withSession (G.clientStart ctxt mechanism) $ \s -> do-	-	G.propertySet s G.GSASL_AUTHZID authz-	G.propertySet s G.GSASL_AUTHID username-	G.propertySet s G.GSASL_PASSWORD password-	G.propertySet s G.GSASL_SERVICE "xmpp"-	G.propertySet s G.GSASL_HOSTNAME hostname-	-	(b64text, rc) <- G.step64 s ""-	S.putTree stream $ mkElement ("", "auth")-		[ ("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")-		 ,("", "mechanism", mechanism)]-		[XN.mkText b64text]-	-	case rc of-		G.GSASL_OK -> saslFinish stream-		G.GSASL_NEEDS_MORE -> saslLoop stream s--saslLoop :: S.Stream -> G.Session -> IO Result-saslLoop stream session = do-	challengeText <- A.runX (-		A.arrIO (\_ -> S.getTree stream)-		>>> A.getChildren-		>>> A.hasQName (mkQName "urn:ietf:params:xml:ns:xmpp-sasl" "challenge")-		>>> A.getChildren >>> A.getText)-	-	if null challengeText then return Failure-		else do-			(b64text, rc) <- G.step64 session (concat challengeText)-			S.putTree stream $ mkElement ("", "response")-				[("", "xmlns", "urn:ietf:params:xml:ns:xmpp-sasl")]-				[XN.mkText b64text]-			case rc of-				G.GSASL_OK -> saslFinish stream-				G.GSASL_NEEDS_MORE -> saslLoop stream session--saslFinish :: S.Stream -> IO Result-saslFinish stream = do-	successElem <- A.runX (-		A.arrIO (\_ -> S.getTree stream)-		>>> A.getChildren-		>>> A.hasQName (mkQName "urn:ietf:params:xml:ns:xmpp-sasl" "success"))-	-	return $ if null successElem then Failure else Success--advertisedMechanisms :: [S.StreamFeature] -> [Mechanism]-advertisedMechanisms [] = []-advertisedMechanisms (f:fs) = case f of-	(S.FeatureSASL ms) -> ms-	_ -> advertisedMechanisms fs-

@@ -0,0 +1,274 @@+-- 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.Stanza+	( Stanza (..)+	+	, ReceivedStanza (..)+	, Message (..)+	, Presence (..)+	, IQ (..)+	, MessageType (..)+	, PresenceType (..)+	, IQType (..)+	+	, emptyMessage+	, emptyPresence+	, emptyIQ+	+	, elementToStanza+	) where++import Control.Monad (when)+import qualified Data.Text.Lazy as T+import qualified Network.Protocol.XMPP.XML as X+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 -> [X.Element]+	stanzaToElement :: a -> X.Element++data ReceivedStanza+	= ReceivedMessage Message+	| ReceivedPresence Presence+	| ReceivedIQ IQ+	deriving (Show)++data Message = Message+	{ messageType     :: MessageType+	, messageTo       :: Maybe JID+	, messageFrom     :: Maybe JID+	, messageID       :: Maybe T.Text+	, messageLang     :: Maybe T.Text+	, messagePayloads :: [X.Element]+	}+	deriving (Show)++instance Stanza Message where+	stanzaTo = messageTo+	stanzaFrom = messageFrom+	stanzaID = messageID+	stanzaLang = messageLang+	stanzaPayloads = messagePayloads+	stanzaToElement x = stanzaToElement' 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 :: [X.Element]+	}+	deriving (Show)++instance Stanza Presence where+	stanzaTo = presenceTo+	stanzaFrom = presenceFrom+	stanzaID = presenceID+	stanzaLang = presenceLang+	stanzaPayloads = presencePayloads+	stanzaToElement x = stanzaToElement' 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 :: Maybe X.Element+	}+	deriving (Show)++instance Stanza IQ where+	stanzaTo = iqTo+	stanzaFrom = iqFrom+	stanzaID = iqID+	stanzaLang = iqLang+	stanzaPayloads iq = case iqPayload iq of+		Just elemt -> [elemt]+		Nothing -> []+	stanzaToElement x = stanzaToElement' 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 -> IQ+emptyIQ t = IQ+	{ iqType = t+	, iqTo = Nothing+	, iqFrom = Nothing+	, iqID = Nothing+	, iqLang = Nothing+	, iqPayload = Nothing+	}++stanzaToElement' :: Stanza a => a -> T.Text -> T.Text -> X.Element+stanzaToElement' stanza name typeStr = X.element name attrs payloads where+	payloads = map X.NodeElement $ stanzaPayloads stanza+	attrs = concat+		[ mattr "to" $ fmap formatJID . stanzaTo+		, mattr "from" $ fmap formatJID . stanzaFrom+		, mattr "id" stanzaID+		, mattr "xml:lang" stanzaLang+		, if T.null typeStr then [] else [("type", typeStr)]+		]+	mattr label f = case f stanza of+		Nothing -> []+		Just text -> [(label, text)]++elementToStanza :: T.Text -> X.Element -> Maybe ReceivedStanza+elementToStanza ns elemt = do+	let elemNS = X.nameNamespace . X.elementName $ elemt+	when (elemNS /= Just ns) Nothing+	+	let elemName = X.nameLocalName . X.elementName $ elemt+	case elemName of+		"message" -> ReceivedMessage `fmap` parseMessage elemt+		"presence" -> ReceivedPresence `fmap` parsePresence elemt+		"iq" -> ReceivedIQ `fmap` parseIQ elemt+		_ -> Nothing++parseMessage :: X.Element -> Maybe Message+parseMessage elemt = do+	typeStr <- X.getattr (X.name "type") elemt+	msgType <- case typeStr of+		"normal"    -> Just MessageNormal+		"chat"      -> Just MessageChat+		"groupchat" -> Just MessageGroupChat+		"headline"  -> Just MessageHeadline+		"error"     -> Just MessageError+		_           -> Nothing+	msgTo <- xmlJID "to" elemt+	msgFrom <- xmlJID "from" elemt+	let msgID = X.getattr (X.name "id") elemt+	let msgLang = X.getattr (X.name "lang") elemt+	let payloads = X.elementChildren elemt+	return $ Message msgType msgTo msgFrom msgID msgLang payloads++parsePresence :: X.Element -> Maybe Presence+parsePresence elemt = do+	let typeStr = maybe "" id $ X.getattr (X.name "type") elemt+	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" elemt+	msgFrom <- xmlJID "from" elemt+	let msgID = X.getattr (X.name "id") elemt+	let msgLang = X.getattr (X.name "lang") elemt+	let payloads = X.elementChildren elemt+	return $ Presence pType msgTo msgFrom msgID msgLang payloads++parseIQ :: X.Element -> Maybe IQ+parseIQ elemt = do+	typeStr <- X.getattr (X.name "type") elemt+	iqType <- case typeStr of+		"get"    -> Just IQGet+		"set"    -> Just IQSet+		"result" -> Just IQResult+		"error"  -> Just IQError+		_        -> Nothing+	+	msgTo <- xmlJID "to" elemt+	msgFrom <- xmlJID "from" elemt+	let msgID = X.getattr (X.name "id") elemt+	let msgLang = X.getattr (X.name "lang") elemt+	let payload = case X.elementChildren elemt of+		[] -> Nothing+		child:_ -> Just child+	return $ IQ iqType msgTo msgFrom msgID msgLang payload++xmlJID :: T.Text -> X.Element -> Maybe (Maybe JID)+xmlJID name elemt = case X.getattr (X.name name) elemt of+	Nothing -> Just Nothing+	Just raw -> case parseJID raw of+		Just jid -> Just (Just jid)+		Nothing -> Nothing

@@ -1,145 +0,0 @@-{- Copyright (C) 2009 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.Stanzas (-	 StanzaType(..)-	,Stanza(..)-	,treeToStanza-	,stanzaToTree-	) where--import Text.XML.HXT.DOM.Interface (XmlTree)-import Text.XML.HXT.Arrow ((>>>), (&&&))-import qualified Text.XML.HXT.Arrow as A--import Network.Protocol.XMPP.JID (JID, jidFormat, jidParse)-import Network.Protocol.XMPP.Util (mkElement, mkQName)-import qualified Text.XML.HXT.DOM.XmlNode as XN--data StanzaType =-	  MessageNormal-	| MessageChat-	| MessageGroupChat-	| MessageHeadline-	| MessageError-	-	| PresenceUnavailable-	| PresenceSubscribe-	| PresenceSubscribed-	| PresenceUnsubscribe-	| PresenceUnsubscribed-	| PresenceProbe-	| PresenceError-	-	| IQGet-	| IQSet-	| IQResult-	| IQError-	deriving (Show, Eq)--data Stanza = Stanza-	{-		 stanzaType     :: StanzaType-		,stanzaTo       :: Maybe JID-		,stanzaFrom     :: Maybe JID-		,stanzaID       :: String-		,stanzaLang     :: String-		,stanzaPayloads :: [XmlTree]-	}-	deriving (Show, Eq)--stanzaTypeMap :: [((String, String, String), StanzaType)]-stanzaTypeMap = mkStanzaTypeMap $ [-	 ("jabber:client", "message", [-		 ("normal",    MessageNormal)-		,("chat",      MessageChat)-		,("groupchat", MessageGroupChat)-		,("headline",  MessageHeadline)-		,("error",     MessageError)-		])-	,("jabber:client", "presence", [-		 ("unavailable",  PresenceUnavailable)-		,("subscribe",    PresenceSubscribe)-		,("subscribed",   PresenceSubscribed)-		,("unsubscribe",  PresenceUnsubscribe)-		,("unsubscribed", PresenceUnsubscribed)-		,("probe",        PresenceProbe)-		,("error",        PresenceError)-		])-	,("jabber:client", "iq", [-		 ("get", IQGet)-		,("set", IQSet)-		,("result", IQResult)-		,("error", IQError)-		])-	]-	where mkStanzaTypeMap raw = do-		(ns, elementName, typeStrings) <- raw-		(typeString, type') <- typeStrings-		return ((ns, elementName, typeString), type')--stanzaTypeToStr :: StanzaType -> (String, String, String)-stanzaTypeToStr t = let-	step []              = undefined-	step ((ret, t'):tms)-		| t == t'    = ret-		| otherwise  = step tms-	in step stanzaTypeMap--stanzaTypeFromStr :: String -> String -> String -> Maybe StanzaType-stanzaTypeFromStr ns elementName typeString = let-	key = (ns, elementName, typeString)-	step [] = Nothing-	step ((key', ret):tms)-		| key == key' = Just ret-		| otherwise = step tms-	in step stanzaTypeMap--treeToStanza :: XmlTree -> [Stanza]-treeToStanza t = do-	to <- return . jidParse =<< A.runLA (A.getAttrValue "to") t-	from <- return . jidParse =<< A.runLA (A.getAttrValue "from") t-	id' <- A.runLA (A.getAttrValue "id") t-	lang <- A.runLA (A.getAttrValue "lang") t-	-	ns <- A.runLA A.getNamespaceUri t-	elementName <- A.runLA A.getLocalPart t-	typeString <- A.runLA (A.getAttrValue "type") t-	-	let payloads = A.runLA (A.getChildren >>> A.isElem) t-	-	case stanzaTypeFromStr ns elementName typeString of-		Nothing    -> []-		Just type' -> [Stanza type' to from id' lang payloads]--stanzaToTree :: Stanza -> XmlTree-stanzaToTree s = let-	(ns, elementName, typeString) = stanzaTypeToStr (stanzaType s)-	-	attrs' = [-		 autoAttr "to" (maybe "" jidFormat . stanzaTo)-		,autoAttr "from" (maybe "" jidFormat . stanzaFrom)-		,autoAttr "id" stanzaID-		,autoAttr "xml:lang" stanzaLang-		,\_ -> [("", "type", typeString)]-		]-	attrs = concatMap ($ s) attrs'-	in mkElement (ns, elementName) attrs (stanzaPayloads s)--autoAttr :: String -> (Stanza -> String) -> Stanza -> [(String, String, String)]-autoAttr attr f stanza = case f stanza of-	"" -> []-	text -> [("", attr, text)]

@@ -1,276 +0,0 @@-{- Copyright (C) 2009 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.Stream (-	 Stream (-	 	 streamLanguage-	 	,streamVersion-		,streamID-	 	,streamFeatures-	 	)-	,XMPPStreamID(XMPPStreamID)-	,StreamFeature (-		 FeatureStartTLS-		,FeatureSASL-		,FeatureRegister-		,FeatureBind-		,FeatureSession-		)-	,beginStream-	,restartStream-	,getTree-	,putTree-	) where--import qualified System.IO as IO-import Data.AssocList (lookupDef)-import Data.Char (toUpper)-import Control.Applicative---- XML Parsing-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 qualified Text.XML.LibXML.SAX as SAX---- TLS support-import qualified Network.GnuTLS as GnuTLS-import Foreign (allocaBytes)-import Foreign.C (peekCAStringLen)--import Network.Protocol.XMPP.JID (JID, jidFormat)-import qualified Network.Protocol.XMPP.Util as Util--maxXMPPVersion :: XMPPVersion-maxXMPPVersion = XMPPVersion 1 0--data Stream = Stream-	{-		 streamHandle   :: Handle-		,streamJID      :: JID-		,streamNS       :: String-		,streamParser   :: SAX.Parser-		,streamLanguage :: XMLLanguage-		,streamVersion  :: XMPPVersion-		,streamID       :: XMPPStreamID-		,streamFeatures :: [StreamFeature]-	}--data StreamFeature =-	  FeatureStartTLS Bool-	| FeatureSASL [String]-	| FeatureRegister-	| FeatureBind-	| FeatureSession-	| FeatureUnknown DOM.XmlTree-	deriving (Show, Eq)--newtype XMLLanguage = XMLLanguage String-	deriving (Show, Eq)--data XMPPVersion = XMPPVersion Int Int-	deriving (Show, Eq)--newtype XMPPStreamID = XMPPStreamID String--data Handle =-	  PlainHandle IO.Handle-	| SecureHandle IO.Handle (GnuTLS.Session GnuTLS.Client)----------------------------------------------------------------------------------restartStream :: Stream -> IO Stream-restartStream s = beginStream' (streamJID s) (streamNS s) (streamHandle s)--beginStream :: JID -> String -> IO.Handle -> IO Stream-beginStream jid ns rawHandle = do-	IO.hSetBuffering rawHandle IO.NoBuffering-	-	plainStream <- beginStream' jid ns (PlainHandle rawHandle)--	let startTLS = do-	      putTree plainStream $ Util.mkElement ("", "starttls")-				    [("", "xmlns", "urn:ietf:params:xml:ns:xmpp-tls")]-				    []-	      getTree plainStream-	-	      session <- GnuTLS.tlsClient [-				GnuTLS.handle GnuTLS.:= rawHandle-			       ,GnuTLS.priorities GnuTLS.:= [GnuTLS.CrtX509]-			       ,GnuTLS.credentials GnuTLS.:= GnuTLS.certificateCredentials-			       ]-	      GnuTLS.handshake session-	      beginStream' jid ns (SecureHandle rawHandle session)--	case streamCanTLS plainStream of-	  True -> startTLS-	  False -> return plainStream--beginStream' :: JID -> String -> Handle -> IO Stream-beginStream' jid ns h = do-	-- Since only the opening tag should be written, normal XML-	-- serialization cannot be used. Be careful to escape any embedded-	-- attributes.-	let xmlHeader =-		"<?xml version='1.0'?>\n" ++-		"<stream:stream xmlns='" ++ DOM.attrEscapeXml ns ++ "'" ++-		" to='" ++ (DOM.attrEscapeXml . jidFormat) jid ++ "'" ++-		" version='1.0'" ++-		" xmlns:stream='http://etherx.jabber.org/streams'>"-	-	parser <- SAX.mkParser-	hPutStr h xmlHeader-	initialEvents <- readEventsUntil startOfStream h parser-	-	let startStreamEvent = last initialEvents-	let (language, version, streamID) = parseStartStream startStreamEvent-	features <- (case ns of-		       "jabber:client" ->-			   parseFeatures <$> getTree' h parser-		       _ ->-			   return []-		    )-	-	return $ Stream h jid ns parser language version streamID features-	-	where-		streamName = Util.mkQName "http://etherx.jabber.org/streams" "stream"-		-		startOfStream depth event = case (depth, event) of-			(1, (SAX.BeginElement elemName _)) ->-				streamName == Util.convertQName elemName-			_ -> False--parseStartStream :: SAX.Event -> (XMLLanguage, XMPPVersion, XMPPStreamID)-parseStartStream e = (XMLLanguage lang, XMPPVersion 1 0, XMPPStreamID id)-    where SAX.BeginElement _ attrs = e-	  attr name = maybe "" SAX.attributeValue $-		      m1 $ filter ((name ==) . SAX.qnameLocalName . SAX.attributeName) attrs-	      where m1 (x:_) = Just x-		    m1 _ = Nothing-	  lang = attr "lang"-	  id = attr "id"--parseFeatures :: DOM.XmlTree -> [StreamFeature]-parseFeatures t =-	A.runLA (A.getChildren-		>>> A.hasQName featuresName-		>>> A.getChildren-		>>> A.arrL (\t' -> [parseFeature t'])) t-	where-		featuresName = Util.mkQName "http://etherx.jabber.org/streams" "features"--parseFeature :: DOM.XmlTree -> StreamFeature-parseFeature t = lookupDef FeatureUnknown qname [-	 (("urn:ietf:params:xml:ns:xmpp-tls", "starttls"), parseFeatureTLS)-	,(("urn:ietf:params:xml:ns:xmpp-sasl", "mechanisms"), parseFeatureSASL)-	,(("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))-	] t-	where-		qname = maybe ("", "") (\n -> (DOM.namespaceUri n, DOM.localPart n)) (XN.getName t)--parseFeatureTLS :: DOM.XmlTree -> StreamFeature-parseFeatureTLS t = FeatureStartTLS True -- TODO: detect whether or not required--parseFeatureSASL :: DOM.XmlTree -> StreamFeature-parseFeatureSASL t = let-	mechName = Util.mkQName "urn:ietf:params:xml:ns:xmpp-sasl" "mechanism"-	mechanisms = A.runLA (-		A.getChildren-		>>> A.hasQName mechName-		>>> A.getChildren-		>>> A.getText) t-	-	in FeatureSASL $ map (map toUpper) mechanisms--streamCanTLS :: Stream -> Bool-streamCanTLS = (> 0) . length .-	       filter (\feature ->-			   case feature of-			     FeatureStartTLS _ -> True-			     _ -> False-		      ) . streamFeatures-----------------------------------------------------------------------------------getTree :: Stream -> IO DOM.XmlTree-getTree s = getTree' (streamHandle s) (streamParser s)--getTree' :: Handle -> SAX.Parser -> IO DOM.XmlTree-getTree' h p = do-	events <- readEventsUntil finished h p-	return $ Util.eventsToTree events-	where-		finished 0 (SAX.EndElement _) = True-		finished _ _ = False--putTree :: Stream -> DOM.XmlTree -> IO ()-putTree s t = do-	let root = XN.mkRoot [] [t]-	let h = streamHandle s-	[text] <- A.runX (A.constA root >>> A.writeDocumentToString [-		(A.a_no_xml_pi, "1")-		])-	hPutStr h text-----------------------------------------------------------------------------------readEventsUntil :: (Int -> SAX.Event -> Bool) -> Handle -> SAX.Parser -> IO [SAX.Event]-readEventsUntil done h parser = readEventsUntil' done 0 [] $ do-	char <- hGetChar h-	SAX.parse parser [char] False--readEventsUntil' :: (Int -> SAX.Event -> Bool) -> Int -> [SAX.Event] -> IO [SAX.Event] -> IO [SAX.Event]-readEventsUntil' done depth accum getEvents = do-	events <- getEvents-	let (done', depth', accum') = readEventsStep done events depth accum-	if done'-		then return accum'-		else readEventsUntil' done depth' accum' getEvents--readEventsStep :: (Int -> SAX.Event -> Bool) -> [SAX.Event] -> Int -> [SAX.Event] -> (Bool, Int, [SAX.Event])-readEventsStep _ [] depth accum = (False, depth, accum)-readEventsStep done (e:es) depth accum = let-	depth' = depth + case e of-		(SAX.BeginElement _ _) -> 1-		(SAX.EndElement _) -> (- 1)-		_ -> 0-	accum' = accum ++ [e]-	in if done depth' e then (True, depth', accum')-	else readEventsStep done es depth' accum'-----------------------------------------------------------------------------------hPutStr :: Handle -> String -> IO ()-hPutStr (PlainHandle h) = IO.hPutStr h-hPutStr (SecureHandle _ session) = GnuTLS.tlsSendString session--hGetChar :: Handle -> IO Char-hGetChar (PlainHandle h) = IO.hGetChar h-hGetChar (SecureHandle h session) = allocaBytes 1 $ \ptr -> do-	pending <- GnuTLS.tlsCheckPending session-	if pending == 0-		then do-			IO.hWaitForInput h (-1)-			return ()-		else return ()-	-	len <- GnuTLS.tlsRecv session ptr 1-	[char] <- peekCAStringLen (ptr, len)-	return char

@@ -1,97 +0,0 @@-{- Copyright (C) 2009 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.Util (-	 eventsToTree-	,convertAttr-	,convertQName-	,mkElement-	,mkAttr-	,mkQName-	) where--import qualified Text.XML.HXT.DOM.XmlNode as XN-import qualified Text.XML.HXT.DOM.Interface as DOM-import qualified Text.XML.LibXML.SAX as SAX------------------------------------------------------------------------------------ For converting incremental XML event lists to HXT trees------------------------------------------------------------------------------------ This function assumes the input list is valid. No validation is performed.-eventsToTree :: [SAX.Event] -> DOM.XmlTree-eventsToTree es = XN.mkRoot [] (eventsToTrees es)--eventsToTrees :: [SAX.Event] -> [DOM.XmlTree]-eventsToTrees es = concatMap blockToTrees (splitBlocks es)---- Split event list into a sequence of "blocks", which are the events including--- and between a pair of tags. <start><start2/></start> and <start/> are both--- single blocks.-splitBlocks :: [SAX.Event] -> [[SAX.Event]]-splitBlocks es = ret where (_, _, ret) = foldl splitBlocks' (0, [], []) es--splitBlocks' :: (Int, [SAX.Event], [[SAX.Event]])-                -> SAX.Event-                -> (Int, [SAX.Event], [[SAX.Event]])-splitBlocks' (depth, accum, allAccum) e =-	if depth' == 0 then-		(depth', [], allAccum ++ [accum'])-	else-		(depth', accum', allAccum)-	where-		accum' = accum ++ [e]-		depth' = depth + case e of-			(SAX.BeginElement _ _) -> 1-			(SAX.EndElement _) -> (- 1)-			_ -> 0--blockToTrees :: [SAX.Event] -> [DOM.XmlTree]-blockToTrees [] = []-blockToTrees (begin:rest) = let end = (last rest) in case (begin, end) of-	(SAX.BeginElement qname attrs, SAX.EndElement _) ->-		[XN.mkElement (convertQName qname)-			(map convertAttr attrs)-			(eventsToTrees (init rest))]-	(SAX.Characters s, _) -> [XN.mkText s]-	(_, SAX.ParseError text) -> error text-	_ -> []--convertAttr :: SAX.Attribute -> DOM.XmlTree-convertAttr (SAX.Attribute qname value) = XN.NTree-	(XN.mkAttrNode (convertQName qname))-	[XN.mkText value]--convertQName :: SAX.QName -> DOM.QName-convertQName (SAX.QName ns _ local) = mkQName ns local------------------------------------------------------------------------------------ Utility function for building XML trees----------------------------------------------------------------------------------mkElement :: (String, String) -> [(String, String, String)] -> [DOM.XmlTree] -> DOM.XmlTree-mkElement (ns, localpart) attrs children = let-	qname = mkQName ns localpart-	attrs' = [mkAttr ans alp text | (ans, alp, text) <- attrs]-	in XN.mkElement qname attrs' children--mkAttr :: String -> String -> String -> DOM.XmlTree-mkAttr ns localpart text = XN.mkAttr (mkQName ns localpart) [XN.mkText text]--mkQName :: String -> String -> DOM.QName-mkQName ns localpart = case ns of-	"" -> DOM.mkName localpart-	_ -> DOM.mkNsName localpart ns

@@ -0,0 +1,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'

@@ -1,7 +1,7 @@ name: network-protocol-xmpp-version: 0.2.1+version: 0.3 synopsis: Client <-> Server communication over XMPP-license: GPL+license: GPL-3 license-file: License.txt author: John Millikin <jmillikin@gmail.com>         Stephan Maka  <stephan@spaceboyz.net>@@ -17,23 +17,34 @@   location: http://ianen.org/haskell/xmpp/  library+  ghc-options: -Wall -fno-warn-unused-do-bind+   build-depends:-    base >=3 && < 5,-    hxt >= 8.5 && < 8.6,-    libxml-sax >= 0.3 && < 0.4,-    hsgnutls >= 0.2 && < 0.3,-    gsasl >= 0.2 && < 0.3,-    network >= 2.2 && < 2.3,-    bytestring >= 0.9 && < 1.0,-    SHA >= 1.4 && < 1.5+      base >=3 && < 5+    , text >= 0.7 && < 0.8+    , gnuidn >= 0.1 && < 0.2+    , gnutls >= 0.1 && < 0.3+    , bytestring >= 0.9 && < 0.10+    , libxml-sax >= 0.4 && < 0.5+    , gsasl >= 0.3 && < 0.4+    , network >= 2.2 && < 2.3+    , transformers >= 0.2 && < 0.3+    , monads-tf >= 0.1 && < 0.2+    , xml-types >= 0.1 && < 0.2+    , failable-list >= 0.2 && < 0.3    exposed-modules:     Network.Protocol.XMPP++  other-modules:     Network.Protocol.XMPP.Client+    Network.Protocol.XMPP.Client.Authentication+    Network.Protocol.XMPP.Client.Features     Network.Protocol.XMPP.Component-    Network.Protocol.XMPP.Connection+    Network.Protocol.XMPP.Connections+    Network.Protocol.XMPP.ErrorT+    Network.Protocol.XMPP.Handle     Network.Protocol.XMPP.JID-    Network.Protocol.XMPP.SASL-    Network.Protocol.XMPP.Stanzas-    Network.Protocol.XMPP.Stream-    Network.Protocol.XMPP.Util+    Network.Protocol.XMPP.Monad+    Network.Protocol.XMPP.Stanza+    Network.Protocol.XMPP.XML