packages feed

network-protocol-xmpp 0.3.3 → 0.4

raw patch · 13 files changed

+321/−327 lines, 13 filesdep ~libxml-saxdep ~xml-types

Dependency ranges changed: libxml-sax, xml-types

Files

Network/Protocol/XMPP.hs view
@@ -1,4 +1,4 @@--- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>+-- Copyright (C) 2010-2011 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@@ -13,7 +13,6 @@ -- 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 	(  	-- * JIDs@@ -65,9 +64,10 @@ 	, getSession 	, runXMPP 	) where-import Network.Protocol.XMPP.Client-import Network.Protocol.XMPP.Component-import Network.Protocol.XMPP.Connections-import Network.Protocol.XMPP.JID-import Network.Protocol.XMPP.Monad-import Network.Protocol.XMPP.Stanza++import           Network.Protocol.XMPP.Client+import           Network.Protocol.XMPP.Component+import           Network.Protocol.XMPP.Connections+import           Network.Protocol.XMPP.JID+import           Network.Protocol.XMPP.Monad+import           Network.Protocol.XMPP.Stanza
Network/Protocol/XMPP/Client.hs view
@@ -1,4 +1,6 @@--- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>+{-# LANGUAGE OverloadedStrings #-}++-- Copyright (C) 2010-2011 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@@ -13,17 +15,17 @@ -- 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 	( runClient 	, bindJID 	) where-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           Control.Monad ((>=>))+import           Control.Monad.Error (throwError)+import           Control.Monad.Trans (liftIO)+import           Data.ByteString (ByteString)+import           Data.Text (Text)+import           Network (connectTo) import qualified System.IO as IO  import qualified Network.Protocol.XMPP.Client.Authentication as A@@ -33,13 +35,13 @@ 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+import           Network.Protocol.XMPP.ErrorT+import           Network.Protocol.XMPP.Stanza  runClient :: C.Server           -> J.JID -- ^ Client JID-          -> T.Text -- ^ Username-          -> T.Text -- ^ Password+          -> Text -- ^ Username+          -> Text -- ^ Password           -> M.XMPP a           -> IO (Either M.Error a) runClient server jid username password xmpp = do@@ -59,7 +61,7 @@  newStream :: J.JID -> M.XMPP [F.Feature] newStream jid = do-	M.putBytes $ C.xmlHeader "jabber:client" jid+	M.putBytes (C.xmlHeader "jabber:client" jid) 	void (M.readEvents C.startOfStream) 	F.parseFeatures `fmap` M.getElement @@ -70,10 +72,10 @@ 		M.putElement xmlStartTLS 		void M.getElement 		h <- M.getHandle-		eitherTLS <- liftIO $ runErrorT $ H.startTLS h+		eitherTLS <- liftIO (runErrorT (H.startTLS h)) 		case eitherTLS of-			Left err -> throwError $ M.TransportError err-			Right tls -> M.restartXMPP (Just tls) $ newStream sjid >>= m+			Left err -> throwError (M.TransportError err)+			Right tls -> M.restartXMPP (Just tls) (newStream sjid >>= m)  authenticationMechanisms :: [F.Feature] -> [ByteString] authenticationMechanisms = step where@@ -90,11 +92,11 @@ bindJID :: J.JID -> M.XMPP J.JID bindJID jid = do 	-- Bind-	M.putStanza . bindStanza . J.jidResource $ jid+	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.isNamed "{urn:ietf:params:xml:ns:xmpp-bind}jid" 		>=> X.elementNodes 		>=> X.isContent 		>=> return . X.contentText@@ -111,28 +113,27 @@ 	 	returnedJID <- case maybeJID of 		Just x -> return x-		Nothing -> throwError $ M.InvalidBindResult bindResult+		Nothing -> throwError (M.InvalidBindResult bindResult) 	 	-- Session 	M.putStanza sessionStanza 	void M.getStanza 	-	M.putStanza $ emptyPresence PresenceAvailable+	M.putStanza (emptyPresence PresenceAvailable) 	void M.getStanza 	 	return returnedJID  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+	payload = X.element "{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]]+		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" [] []+	payload = X.element "{urn:ietf:params:xml:ns:xmpp-session}session" [] []  streamSupportsTLS :: [F.Feature] -> Bool streamSupportsTLS = any isStartTLS where@@ -140,7 +141,7 @@ 	isStartTLS _                     = False  xmlStartTLS :: X.Element-xmlStartTLS = X.nselement "urn:ietf:params:xml:ns:xmpp-tls" "starttls" [] []+xmlStartTLS = X.element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] []  void :: Monad m => m a -> m () void m = m >> return ()
Network/Protocol/XMPP/Client/Authentication.hs view
@@ -1,4 +1,7 @@--- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com>+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- Copyright (C) 2009-2011 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@@ -13,50 +16,49 @@ -- 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           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           Data.ByteString (ByteString)+import qualified Data.ByteString.Char8+import qualified Data.Text+import           Data.Text (Text)+import           Data.Text.Encoding (encodeUtf8)+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)+import           Network.Protocol.XMPP.JID (JID, formatJID, jidResource)  data Result = Success | Failure 	deriving (Show, Eq) -data AuthException = XmppError M.Error | SaslError TL.Text+data AuthException = XmppError M.Error | SaslError Text 	deriving (Typeable, Show)  instance Exc.Exception AuthException -authenticate :: [B.ByteString] -- ^ Mechanisms+authenticate :: [ByteString] -- ^ Mechanisms              -> JID -- ^ User JID              -> JID -- ^ Server JID-             -> TL.Text -- ^ Username-             -> TL.Text -- ^ Password+             -> Text -- ^ Username+             -> Text -- ^ Password              -> M.XMPP () authenticate xmppMechanisms userJID serverJID username password = xmpp where 	mechanisms = map SASL.Mechanism xmppMechanisms-	authz = formatJID $ userJID { jidResource = Nothing }+	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+		res <- liftIO . Exc.try . SASL.runSASL $ do 			suggested <- SASL.clientSuggestMechanism mechanisms 			case suggested of 				Nothing -> saslError "No supported authentication mechanism"@@ -65,21 +67,21 @@ 			Right Success -> return () 			Right Failure -> E.throwError M.AuthenticationFailure 			Left (XmppError err) -> E.throwError err-			Left (SaslError err) -> E.throwError $ M.AuthenticationError 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+			SASL.setProperty SASL.PropertyAuthzID (encodeUtf8 authz)+			SASL.setProperty SASL.PropertyAuthID (encodeUtf8 username)+			SASL.setProperty SASL.PropertyPassword (encodeUtf8 password)+			SASL.setProperty SASL.PropertyService "xmpp"+			SASL.setProperty SASL.PropertyHostname (encodeUtf8 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]+			(b64text, rc) <- SASL.step64 ""+			putElement ctx $ X.element "{urn:ietf:params:xml:ns:xmpp-sasl}auth"+				[("mechanism", Data.Text.pack (Data.ByteString.Char8.unpack mechBytes))]+				[X.NodeContent (X.ContentText (Data.Text.pack (Data.ByteString.Char8.unpack b64text)))] 			 			case rc of 				SASL.Complete -> saslFinish ctx@@ -87,23 +89,23 @@ 			 		case sessionResult of 			Right x -> return x-			Left err -> saslError $ TL.pack $ show err+			Left err -> saslError (Data.Text.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 name = "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" 	let getChallengeText = 		X.isNamed name 		>=> X.elementNodes 		>=> X.isContent 		>=> return . X.contentText 	let challengeText = getChallengeText elemt-	when (null challengeText) $ saslError "Received empty challenge"+	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]+	(b64text, rc) <- SASL.step64 (Data.ByteString.Char8.pack (concatMap Data.Text.unpack challengeText))+	putElement ctx $ X.element "{urn:ietf:params:xml:ns:xmpp-sasl}response"+		[] [X.NodeContent (X.ContentText (Data.Text.pack (Data.ByteString.Char8.unpack b64text)))] 	case rc of 		SASL.Complete -> saslFinish ctx 		SASL.NeedsMore -> saslLoop ctx@@ -111,23 +113,23 @@ 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 name = "{urn:ietf:params:xml:ns:xmpp-sasl}success" 	let success = X.isNamed name elemt-	return $ if null success then Failure else Success+	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+	res <- M.runXMPP ctx (M.putElement elemt) 	case res of-		Left err -> Exc.throwIO $ XmppError err+		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+		Left err -> Exc.throwIO (XmppError err) 		Right x -> return x -saslError :: MonadIO m => TL.Text -> m a+saslError :: MonadIO m => Text -> m a saslError = liftIO . Exc.throwIO . SaslError
Network/Protocol/XMPP/Client/Features.hs view
@@ -1,4 +1,6 @@--- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>+{-# LANGUAGE OverloadedStrings #-}++-- Copyright (C) 2010-2011 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@@ -13,20 +15,21 @@ -- 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           Control.Arrow ((&&&))+import qualified Data.ByteString.Char8+import           Data.ByteString (ByteString)+import qualified Data.Text import qualified Network.Protocol.XMPP.XML as X  data Feature = 	  FeatureStartTLS Bool-	| FeatureSASL [B.ByteString]+	| FeatureSASL [ByteString] 	| FeatureRegister 	| FeatureBind 	| FeatureSession@@ -59,10 +62,10 @@ 	>>= X.isNamed nameMechanism 	>>= X.elementNodes 	>>= X.isContent-	>>= return . B.pack . TL.unpack . X.contentText+	>>= return . Data.ByteString.Char8.pack . Data.Text.unpack . X.contentText  nameMechanism :: X.Name-nameMechanism = X.Name "mechanism" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing+nameMechanism = "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism"  nameFeatures :: X.Name-nameFeatures = X.Name "features" (Just "http://etherx.jabber.org/streams") Nothing+nameFeatures = "{http://etherx.jabber.org/streams}features"
Network/Protocol/XMPP/Component.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE OverloadedStrings #-}+ -- Copyright (C) 2010 Stephan Maka <stephan@spaceboyz.net>--- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>+-- Copyright (C) 2010-2011 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@@ -14,30 +16,31 @@ -- 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.Component 	( runComponent 	) where-import Control.Monad (when)-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           Control.Monad (when)+import           Control.Monad.Error (throwError)+import           Data.Bits (shiftR, (.&.))+import           Data.Char (intToDigit)+import qualified Data.ByteString+import           Data.ByteString (ByteString)+import qualified Data.Text+import           Data.Text (Text)+import           Data.Text.Encoding (encodeUtf8)+import           Network (connectTo)+import           Network.Protocol.SASL.GNU (sha1) import qualified System.IO as IO  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)+import           Network.Protocol.XMPP.JID (JID)  runComponent :: C.Server-             -> T.Text -- ^ Server secret+             -> Text -- ^ Server secret              -> M.XMPP a              -> IO (Either M.Error a) runComponent server password xmpp = do@@ -50,7 +53,7 @@ 		authenticate streamID password 		xmpp -beginStream :: JID -> M.XMPP T.Text+beginStream :: JID -> M.XMPP Text beginStream jid = do 	M.putBytes $ C.xmlHeader "jabber:component:accept" jid 	events <- M.readEvents C.startOfStream@@ -58,30 +61,25 @@ 		Nothing -> throwError M.NoComponentStreamID 		Just x -> return x -parseStreamID :: X.SaxEvent -> Maybe T.Text-parseStreamID (X.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 :: X.Event -> Maybe Text+parseStreamID (X.EventBeginElement name attrs) = X.attributeText+	"{jabber:component:accept}jid"+	(X.Element name attrs []) parseStreamID _ = Nothing -authenticate :: T.Text -> T.Text -> M.XMPP ()+authenticate :: Text -> 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]+	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+	let nameHandshake = "{jabber:component:accept}handshake"+	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+buildSecret :: Text -> Text -> ByteString+buildSecret sid password = encodeUtf8 (X.escape (Data.Text.append sid password)) -showDigest :: B.ByteString -> T.Text-showDigest = T.pack . concatMap wordToHex . B.unpack where-	wordToHex x = [hexDig $ shiftR x 4, hexDig $ x .&. 0xF]+showDigest :: ByteString -> Text+showDigest = Data.Text.pack . concatMap wordToHex . Data.ByteString.unpack where+	wordToHex x = [hexDig (shiftR x 4), hexDig (x .&. 0xF)] 	hexDig = intToDigit . fromIntegral
Network/Protocol/XMPP/Connections.hs view
@@ -1,4 +1,6 @@--- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>+{-# LANGUAGE OverloadedStrings #-}++-- Copyright (C) 2010-2011 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@@ -13,20 +15,21 @@ -- 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           Network (HostName, PortID)+import           Data.ByteString (ByteString)+import qualified Data.Text+import           Data.Text (Text)+import           Data.Text.Encoding (encodeUtf8)+ import qualified Network.Protocol.XMPP.XML as X-import Network.Protocol.XMPP.JID (JID, formatJID)+import           Network.Protocol.XMPP.JID (JID, formatJID)  data Server = Server 	{ serverJID      :: JID@@ -37,10 +40,10 @@ -- 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 :: Text -> JID -> ByteString xmlHeader ns jid = encodeUtf8 header where-	attr x = T.concat ["\"", X.escape x, "\""]-	header = T.concat+	attr x = Data.Text.concat ["\"", X.escape x, "\""]+	header = Data.Text.concat 		[ "<?xml version='1.0'?>\n" 		, "<stream:stream xmlns=" , attr ns 		, " to=", attr (formatJID jid)@@ -48,10 +51,10 @@ 		, " xmlns:stream=\"http://etherx.jabber.org/streams\">" 		] -startOfStream :: Integer -> X.SaxEvent -> Bool+startOfStream :: Integer -> X.Event -> Bool startOfStream depth event = case (depth, event) of-	(1, (X.BeginElement elemName _)) -> qnameStream == elemName+	(1, (X.EventBeginElement elemName _)) -> qnameStream == elemName 	_ -> False  qnameStream :: X.Name-qnameStream = X.Name "stream" (Just "http://etherx.jabber.org/streams") Nothing+qnameStream = "{http://etherx.jabber.org/streams}stream"
Network/Protocol/XMPP/ErrorT.hs view
@@ -1,4 +1,6 @@--- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>+{-# LANGUAGE TypeFamilies #-}++-- Copyright (C) 2010-2011 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@@ -13,16 +15,15 @@ -- 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           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 @@ -38,8 +39,8 @@ 	(>>=) m k = ErrorT $ do 		x <- runErrorT m 		case x of-			Left l -> return $ Left l-			Right r -> runErrorT $ k r+			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@@ -47,8 +48,8 @@ 	catchError m h = ErrorT $ do 		x <- runErrorT m 		case x of-			Left l -> runErrorT $ h l-			Right r -> return $ Right r+			Left l -> runErrorT (h l)+			Right r -> return (Right r)  instance MonadTrans (ErrorT e) where 	lift = ErrorT . liftM Right@@ -69,4 +70,4 @@ mapErrorT :: (m (Either e a) -> n (Either e' b))            -> ErrorT e m a            -> ErrorT e' n b-mapErrorT f m = ErrorT $ f (runErrorT m)+mapErrorT f m = ErrorT (f (runErrorT m))
Network/Protocol/XMPP/Handle.hs view
@@ -1,4 +1,6 @@--- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>+{-# LANGUAGE OverloadedStrings #-}++-- Copyright (C) 2010-2011 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@@ -13,7 +15,6 @@ -- 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@@ -21,30 +22,33 @@ 	, hGetBytes 	) where -import Control.Monad (when)+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           Control.Monad.Trans (liftIO)+import qualified Data.ByteString+import           Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy+import qualified Data.Text+import           Data.Text (Text) import qualified System.IO as IO import qualified Network.Protocol.TLS.GNU as TLS-import Network.Protocol.XMPP.ErrorT+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 :: TLS.Session -> TLS.TLS a -> ErrorT Text IO a liftTLS s = liftTLS' . TLS.runTLS s -liftTLS' :: IO (Either TLS.Error a) -> ErrorT T.Text IO a+liftTLS' :: IO (Either TLS.Error a) -> ErrorT Text IO a liftTLS' io = do 	eitherX <- liftIO io 	case eitherX of-		Left err -> E.throwError $ T.pack $ show err+		Left err -> E.throwError (Data.Text.pack (show err)) 		Right x -> return x -startTLS :: Handle -> ErrorT T.Text IO Handle+startTLS :: Handle -> ErrorT 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]@@ -52,14 +56,16 @@ 	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+hPutBytes :: Handle -> ByteString -> ErrorT Text IO ()+hPutBytes (PlainHandle h)  = liftIO . Data.ByteString.hPut h+hPutBytes (SecureHandle _ s) = liftTLS s . TLS.putBytes . toLazy where+	toLazy bytes = Data.ByteString.Lazy.fromChunks [bytes] -hGetBytes :: Handle -> Integer -> ErrorT T.Text IO B.ByteString-hGetBytes (PlainHandle h) n = liftIO $  B.hGet h $ fromInteger n+hGetBytes :: Handle -> Integer -> ErrorT Text IO ByteString+hGetBytes (PlainHandle h) n = liftIO (Data.ByteString.hGet h (fromInteger n)) hGetBytes (SecureHandle h s) n = liftTLS s $ do 	pending <- TLS.checkPending 	let wait = IO.hWaitForInput h (- 1) >> return () 	when (pending == 0) (liftIO wait)-	TLS.getBytes n+	lazy <- TLS.getBytes n+	return (Data.ByteString.concat (Data.ByteString.Lazy.toChunks lazy))
Network/Protocol/XMPP/JID.hs view
@@ -1,4 +1,7 @@--- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}++-- Copyright (C) 2010-2011 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@@ -13,8 +16,6 @@ -- 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 CPP #-} module Network.Protocol.XMPP.JID 	( JID (..) 	, Node (..)@@ -25,10 +26,11 @@ 	, parseJID_ 	, formatJID 	) where-import qualified Data.Text.Lazy as TL-import           Data.Text.Lazy (Text)++import qualified Data.Text+import           Data.Text (Text) import qualified Data.Text.IDN.StringPrep as SP-import Data.String (IsString, fromString)+import           Data.String (IsString, fromString)  newtype Node = Node { strNode :: Text } newtype Domain = Domain { strDomain :: Text }@@ -72,25 +74,27 @@ parseJID :: Text -> Maybe JID parseJID str = maybeJID where 	(node, postNode) = case textSpanBy (/= '@') str of-		(x, y) -> if TL.null y+		(x, y) -> if Data.Text.null y 			then ("", x)-			else (x, TL.drop 1 y)+			else (x, Data.Text.drop 1 y) 	(domain, resource) = case textSpanBy (/= '/') postNode of-		(x, y) -> if TL.null y+		(x, y) -> if Data.Text.null y 			then (x, "")-			else (x, TL.drop 1 y)-	nullable x f = if TL.null x then Just Nothing else fmap Just $ f x+			else (x, Data.Text.drop 1 y)+	nullable x f = if Data.Text.null x+		then Just Nothing+		else fmap Just (f x) 	maybeJID = do-		preppedNode <- nullable node $ stringprepM SP.xmppNode+		preppedNode <- nullable node (stringprepM SP.xmppNode) 		preppedDomain <- stringprepM SP.nameprep domain-		preppedResource <- nullable resource $ stringprepM SP.xmppResource+		preppedResource <- nullable resource (stringprepM SP.xmppResource) 		return $ JID 			(fmap Node preppedNode) 			(Domain preppedDomain) 			(fmap Resource preppedResource)-	stringprepM p x = case SP.stringprep p SP.defaultFlags (TL.toStrict x) of+	stringprepM p x = case SP.stringprep p SP.defaultFlags x of 		Left _ -> Nothing-		Right y -> Just (TL.fromStrict y)+		Right y -> Just y  parseJID_ :: Text -> JID parseJID_ text = case parseJID text of@@ -99,9 +103,9 @@  formatJID :: JID -> Text formatJID (JID node (Domain domain) resource) = formatted where-	formatted = TL.concat [node', domain, resource']-	node' = maybe "" (\(Node x) -> TL.append x "@") node-	resource' = maybe "" (\(Resource x) -> TL.append "/" x) resource+	formatted = Data.Text.concat [node', domain, resource']+	node' = maybe "" (\(Node x) -> Data.Text.append x "@") node+	resource' = maybe "" (\(Resource x) -> Data.Text.append "/" x) resource  -- Similar to 'comparing' equaling :: Eq a => (b -> a) -> b -> b -> Bool@@ -110,7 +114,7 @@ -- multi-version 'text' compatibility textSpanBy :: (Char -> Bool) -> Text -> (Text, Text) #if MIN_VERSION_text(0,11,0)-textSpanBy = TL.span+textSpanBy = Data.Text.span #else-textSpanBy = TL.spanBy+textSpanBy = Data.Text.spanBy #endif
Network/Protocol/XMPP/Monad.hs view
@@ -1,4 +1,7 @@--- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}++-- Copyright (C) 2010-2011 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@@ -13,8 +16,6 @@ -- 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 (..)@@ -34,18 +35,20 @@ 	, putElement 	, putStanza 	) where+ import qualified Control.Applicative as A import qualified Control.Concurrent.MVar as M-import Control.Monad (ap)-import Control.Monad.Fix (MonadFix, mfix)-import Control.Monad.Trans (MonadIO, liftIO)+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.ByteString+import           Data.ByteString (ByteString)+import           Data.Text (Text)+import           Data.Text.Encoding (encodeUtf8) -import Network.Protocol.XMPP.ErrorT+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@@ -87,7 +90,7 @@  instance Monad XMPP where 	return = XMPP . return-	m >>= f = XMPP $ unXMPP m >>= unXMPP . f+	m >>= f = XMPP (unXMPP m >>= unXMPP . f)  instance MonadIO XMPP where 	liftIO = XMPP . liftIO@@ -95,14 +98,14 @@ instance E.MonadError XMPP where 	type E.ErrorType XMPP = Error 	throwError = XMPP . E.throwError-	catchError m h = XMPP $ E.catchError (unXMPP m) (unXMPP . h)+	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+	mfix f = XMPP (mfix (unXMPP . f))  runXMPP :: Session -> XMPP a -> IO (Either Error a) runXMPP s xmpp = R.runReaderT (runErrorT (unXMPP xmpp)) s@@ -117,15 +120,15 @@ restartXMPP :: Maybe H.Handle -> XMPP a -> XMPP a restartXMPP newH xmpp = do 	Session oldH ns _ readLock writeLock <- getSession-	sax <- liftIO $ X.newParser+	sax <- liftIO X.newParser 	let s = Session (maybe oldH id newH) ns sax readLock writeLock-	XMPP $ R.local (const s) (unXMPP xmpp)+	XMPP (R.local (const s) (unXMPP xmpp))  withLock :: (Session -> M.MVar ()) -> XMPP a -> XMPP a withLock getLock xmpp = do 	s <- getSession 	let mvar = getLock s-	res <- liftIO $ M.withMVar mvar $ \_ -> runXMPP s xmpp+	res <- liftIO (M.withMVar mvar (\_ -> runXMPP s xmpp)) 	case res of 		Left err -> E.throwError err 		Right x -> return x@@ -138,15 +141,15 @@  liftTLS :: ErrorT Text IO a -> XMPP a liftTLS io = do-	res <- liftIO $ runErrorT io+	res <- liftIO (runErrorT io) 	case res of-		Left err -> E.throwError $ TransportError err+		Left err -> E.throwError (TransportError err) 		Right x -> return x -putBytes :: B.ByteString -> XMPP ()+putBytes :: ByteString -> XMPP () putBytes bytes = do 	h <- getHandle-	liftTLS $ H.hPutBytes h bytes+	liftTLS (H.hPutBytes h bytes)  putElement :: X.Element -> XMPP () putElement = putBytes . encodeUtf8 . X.serialiseElement@@ -154,17 +157,17 @@ putStanza :: S.Stanza a => a -> XMPP () putStanza = withLock sessionWriteLock . putElement . S.stanzaToElement -readEvents :: (Integer -> X.SaxEvent -> Bool) -> XMPP [X.SaxEvent]+readEvents :: (Integer -> X.Event -> Bool) -> XMPP [X.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-			let eof = B.length bytes == 0-			parsed <- liftIO $ X.parse p bytes eof+			bytes <- liftTLS (H.hGetBytes h 1)+			let eof = Data.ByteString.null bytes+			parsed <- liftIO (X.parse p bytes eof) 			case parsed of-				Left err -> E.throwError $ TransportError err+				Left err -> E.throwError (TransportError err) 				Right events -> return events 		X.readEvents done nextEvents @@ -174,9 +177,9 @@ 		events <- readEvents endOfTree 		case X.eventsToElement events of 			Just x -> return x-			Nothing -> E.throwError $ TransportError "getElement: invalid event list"+			Nothing -> E.throwError (TransportError "getElement: invalid event list") 	-	endOfTree 0 (X.EndElement _) = True+	endOfTree 0 (X.EventEndElement _) = True 	endOfTree _ _ = False  getStanza :: XMPP S.ReceivedStanza@@ -185,4 +188,4 @@ 	Session _ ns _ _ _ <- getSession 	case S.elementToStanza ns elemt of 		Just x -> return x-		Nothing -> E.throwError $ InvalidStanza elemt+		Nothing -> E.throwError (InvalidStanza elemt)
Network/Protocol/XMPP/Stanza.hs view
@@ -1,4 +1,6 @@--- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>+{-# LANGUAGE OverloadedStrings #-}++-- Copyright (C) 2010-2011 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@@ -13,7 +15,6 @@ -- 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 (..) 	@@ -32,16 +33,17 @@ 	, elementToStanza 	) where -import Control.Monad (when)-import qualified Data.Text.Lazy as T+import           Control.Monad (when)+import qualified Data.Text+import           Data.Text (Text) import qualified Network.Protocol.XMPP.XML as X-import Network.Protocol.XMPP.JID (JID, parseJID, formatJID)+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+	stanzaID        :: a -> Maybe Text+	stanzaLang      :: a -> Maybe Text 	stanzaPayloads  :: a -> [X.Element] 	stanzaToElement :: a -> X.Element @@ -55,8 +57,8 @@ 	{ messageType     :: MessageType 	, messageTo       :: Maybe JID 	, messageFrom     :: Maybe JID-	, messageID       :: Maybe T.Text-	, messageLang     :: Maybe T.Text+	, messageID       :: Maybe Text+	, messageLang     :: Maybe Text 	, messagePayloads :: [X.Element] 	} 	deriving (Show)@@ -97,8 +99,8 @@ 	{ presenceType     :: PresenceType 	, presenceTo       :: Maybe JID 	, presenceFrom     :: Maybe JID-	, presenceID       :: Maybe T.Text-	, presenceLang     :: Maybe T.Text+	, presenceID       :: Maybe Text+	, presenceLang     :: Maybe Text 	, presencePayloads :: [X.Element] 	} 	deriving (Show)@@ -145,8 +147,8 @@ 	{ iqType    :: IQType 	, iqTo      :: Maybe JID 	, iqFrom    :: Maybe JID-	, iqID      :: Maybe T.Text-	, iqLang    :: Maybe T.Text+	, iqID      :: Maybe Text+	, iqLang    :: Maybe Text 	, iqPayload :: Maybe X.Element 	} 	deriving (Show)@@ -183,26 +185,26 @@ 	, iqPayload = Nothing 	} -stanzaToElement' :: Stanza a => a -> T.Text -> T.Text -> X.Element+stanzaToElement' :: Stanza a => a -> X.Name -> Text -> X.Element stanzaToElement' stanza name typeStr = X.element name attrs payloads where-	payloads = map X.NodeElement $ stanzaPayloads stanza+	payloads = map X.NodeElement (stanzaPayloads stanza) 	attrs = concat-		[ mattr "to" $ fmap formatJID . stanzaTo-		, mattr "from" $ fmap formatJID . stanzaFrom+		[ 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)]+		, if Data.Text.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 :: Text -> X.Element -> Maybe ReceivedStanza elementToStanza ns elemt = do-	let elemNS = X.nameNamespace . X.elementName $ elemt+	let elemNS = X.nameNamespace (X.elementName elemt) 	when (elemNS /= Just ns) Nothing 	-	let elemName = X.nameLocalName . X.elementName $ elemt+	let elemName = X.nameLocalName (X.elementName elemt) 	case elemName of 		"message" -> ReceivedMessage `fmap` parseMessage elemt 		"presence" -> ReceivedPresence `fmap` parsePresence elemt@@ -211,7 +213,7 @@  parseMessage :: X.Element -> Maybe Message parseMessage elemt = do-	typeStr <- X.getattr (X.name "type") elemt+	typeStr <- X.attributeText "type" elemt 	msgType <- case typeStr of 		"normal"    -> Just MessageNormal 		"chat"      -> Just MessageChat@@ -221,14 +223,14 @@ 		_           -> 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 msgID = X.attributeText "id" elemt+	let msgLang = X.attributeText "lang" elemt 	let payloads = X.elementChildren elemt-	return $ Message msgType msgTo msgFrom msgID msgLang payloads+	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+	let typeStr = maybe "" id (X.attributeText "type" elemt) 	pType <- case typeStr of 		""             -> Just PresenceAvailable 		"unavailable"  -> Just PresenceUnavailable@@ -242,14 +244,14 @@ 		 	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 msgID = X.attributeText "id" elemt+	let msgLang = X.attributeText "lang" elemt 	let payloads = X.elementChildren elemt-	return $ Presence pType msgTo msgFrom msgID msgLang payloads+	return (Presence pType msgTo msgFrom msgID msgLang payloads)  parseIQ :: X.Element -> Maybe IQ parseIQ elemt = do-	typeStr <- X.getattr (X.name "type") elemt+	typeStr <- X.attributeText "type" elemt 	iqType <- case typeStr of 		"get"    -> Just IQGet 		"set"    -> Just IQSet@@ -259,15 +261,15 @@ 	 	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 msgID = X.attributeText "id" elemt+	let msgLang = X.attributeText "lang" elemt 	let payload = case X.elementChildren elemt of 		[] -> Nothing 		child:_ -> Just child-	return $ IQ iqType msgTo msgFrom msgID msgLang payload+	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+xmlJID :: X.Name -> X.Element -> Maybe (Maybe JID)+xmlJID name elemt = case X.attributeText name elemt of 	Nothing -> Just Nothing 	Just raw -> case parseJID raw of 		Just jid -> Just (Just jid)
Network/Protocol/XMPP/XML.hs view
@@ -1,4 +1,6 @@--- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>+{-# LANGUAGE OverloadedStrings #-}++-- Copyright (C) 2010-2011 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@@ -13,96 +15,73 @@ -- 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 	 	-- * libxml-sax-0.4 API imitation 	, Parser-	, SaxEvent (..) 	, newParser 	, parse 	, eventsToElement 	 	) where-import Control.Monad (when)-import qualified Data.ByteString.Lazy as B-import qualified Data.Text.Lazy as T-import Data.XML.Types-import Data.IORef (IORef, newIORef, readIORef, writeIORef)-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+import           Control.Monad (when)+import           Data.ByteString (ByteString)+import qualified Data.Text+import           Data.Text (Text)+import           Data.XML.Types+import           Data.IORef (IORef, newIORef, readIORef, writeIORef)+import qualified Text.XML.LibXML.SAX as SAX -contentText :: Content -> T.Text+contentText :: Content -> 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+contentText (ContentEntity e) = Data.Text.concat ["&", e, ";"] -escape :: T.Text -> T.Text-escape = T.concatMap escapeChar where+escape :: Text -> Text+escape = Data.Text.concatMap escapeChar where 	escapeChar c = case c of 		'&' -> "&amp;" 		'<' -> "&lt;" 		'>' -> "&gt;" 		'"' -> "&quot;" 		'\'' -> "&apos;"-		_ -> T.singleton c+		_ -> Data.Text.singleton c -escapeContent :: Content -> T.Text+escapeContent :: Content -> 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+escapeContent (ContentEntity e) = Data.Text.concat ["&", escape e, ";"] -nselement :: T.Text -> T.Text -> [(T.Text, T.Text)] -> [Node] -> Element-nselement ns ln attrs children = Element (nsname ns ln) attrs' children where+element :: Name -> [(Name, Text)] -> [Node] -> Element+element name attrs children = Element name attrs' children where 	attrs' = map (uncurry mkattr) attrs -mkattr :: T.Text -> T.Text -> Attribute-mkattr n val = Attribute (name n) [ContentText val]+mkattr :: Name -> Text -> (Name, [Content])+mkattr n val = (n, [ContentText val])  -- A somewhat primitive serialisation function -- -- TODO: better namespace / prefix handling-serialiseElement :: Element -> T.Text+serialiseElement :: Element -> Text serialiseElement e = text where-	text = T.concat ["<", eName, " ", attrs, ">", contents, "</", eName, ">"]-	eName = formatName $ elementName e+	text = Data.Text.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 ++ ["\""]+	attrs = Data.Text.intercalate " " (map attr (elementAttributes e ++ nsattr))+	attr (n, c) = Data.Text.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+	contents = Data.Text.concat (map serialiseNode (elementNodes e)) 	 	serialiseNode (NodeElement e') = serialiseElement e' 	serialiseNode (NodeContent c) = escape (contentText c)@@ -111,14 +90,12 @@  -- quick-and-dirty imitation of libxml-sax-0.4 API; later, this should -- probably be rewritten to use ST and discard the list parsing-data Parser = Parser (SAX.Parser IO) (IORef (Either T.Text [SaxEvent]))+data Parser = Parser (SAX.Parser IO) (IORef (Either Text [Event]))  newParser :: IO Parser newParser = do-	let toLazy t = T.fromChunks [t]-	 	ref <- newIORef (Right [])-	p <- SAX.newParserIO (\err -> writeIORef ref (Left $ toLazy err)) Nothing+	p <- SAX.newParserIO Nothing 	 	let addEvent e = do 		x <- readIORef ref@@ -127,35 +104,29 @@ 			Right es -> writeIORef ref (Right (e:es)) 		return True 	-	SAX.setCallback p SAX.parsedBeginElement (\name' attrs -> addEvent $ BeginElement name' attrs)-	SAX.setCallback p SAX.parsedEndElement (\name' -> addEvent $ EndElement name')-	SAX.setCallback p SAX.parsedCharacters (\txt -> addEvent $ Characters $ toLazy txt)-	SAX.setCallback p SAX.parsedComment (\txt -> addEvent $ Comment $ toLazy txt)-	SAX.setCallback p SAX.parsedInstruction (\i -> addEvent $ ProcessingInstruction i)+	SAX.setCallback p SAX.parsedBeginElement (\name attrs -> addEvent (EventBeginElement name attrs))+	SAX.setCallback p SAX.parsedEndElement (addEvent . EventEndElement)+	SAX.setCallback p SAX.parsedCharacters (addEvent . EventContent . ContentText)+	SAX.setCallback p SAX.parsedComment (addEvent . EventComment)+	SAX.setCallback p SAX.parsedInstruction (addEvent . EventInstruction)+	SAX.setCallback p SAX.reportError (\err -> writeIORef ref (Left err) >> return False) 	-	return $ Parser p ref+	return (Parser p ref) -parse :: Parser -> B.ByteString -> Bool -> IO (Either T.Text [SaxEvent])+parse :: Parser -> ByteString -> Bool -> IO (Either Text [Event]) parse (Parser p ref) bytes finish = do 	writeIORef ref (Right [])-	SAX.parseLazyBytes p bytes-	when finish $ SAX.parseComplete p+	SAX.parseBytes p bytes+	when finish (SAX.parseComplete p) 	eitherEvents <- readIORef ref 	return $ case eitherEvents of 		Left err -> Left err-		Right events -> Right $ reverse events--data SaxEvent-	= BeginElement Name [Attribute]-	| EndElement Name-	| Characters T.Text-	| Comment T.Text-	| ProcessingInstruction Instruction+		Right events -> Right (reverse events)  readEvents :: Monad m-           => (Integer -> SaxEvent -> Bool)-           -> m [SaxEvent]-           -> m [SaxEvent]+           => (Integer -> Event -> Bool)+           -> m [Event]+           -> m [Event] readEvents done nextEvents = readEvents' 0 [] where 	readEvents' depth acc = do 		events <- nextEvents@@ -167,28 +138,28 @@ 	step [] depth acc = (False, depth, acc) 	step (e:es) depth acc = let 		depth' = depth + case e of-			(BeginElement _ _) -> 1-			(EndElement _) -> (- 1)+			(EventBeginElement _ _) -> 1+			(EventEndElement _) -> (- 1) 			_ -> 0 		acc' = e : acc 		in if done depth' e 			then (True, depth', reverse acc') 			else step es depth' acc' --- | Convert a list of events to a single 'X.Element'. If the events do not+-- | Convert a list of events to a single 'Element'. If the events do not -- contain at least one valid element, 'Nothing' will be returned instead.-eventsToElement :: [SaxEvent] -> Maybe Element+eventsToElement :: [Event] -> Maybe Element eventsToElement es = case eventsToNodes es >>= isElement of 	(e:_) -> Just e 	_ -> Nothing -eventsToNodes :: [SaxEvent] -> [Node]+eventsToNodes :: [Event] -> [Node] eventsToNodes = concatMap blockToNodes . splitBlocks  -- 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 :: [SaxEvent] -> [[SaxEvent]]+splitBlocks :: [Event] -> [[Event]] splitBlocks es = ret where 	(_, _, ret) = foldl splitBlocks' (0, [], []) es 	@@ -199,17 +170,17 @@ 		accum' = accum ++ [e] 		depth' :: Integer 		depth' = depth + case e of-			(BeginElement _ _) -> 1-			(EndElement _) -> (- 1)+			(EventBeginElement _ _) -> 1+			(EventEndElement _) -> (- 1) 			_ -> 0 -blockToNodes :: [SaxEvent] -> [Node]+blockToNodes :: [Event] -> [Node] blockToNodes [] = [] blockToNodes (begin:rest) = nodes where 	end = last rest 	nodes = case (begin, end) of-		(BeginElement name' attrs, EndElement _) -> [node name' attrs]-		(Characters t, _) -> [NodeContent (ContentText t)]+		(EventBeginElement name attrs, EventEndElement _) -> [node name attrs]+		(EventContent c, _) -> [NodeContent c] 		_ -> [] 	-	node n as = NodeElement $ Element n as $ eventsToNodes $ init rest+	node n as = NodeElement (Element n as (eventsToNodes (init rest)))
network-protocol-xmpp.cabal view
@@ -1,5 +1,5 @@ name: network-protocol-xmpp-version: 0.3.3+version: 0.4 synopsis: Client->Server XMPP license: GPL-3 license-file: License.txt@@ -31,8 +31,8 @@     , network >= 2.2 && < 2.4     , transformers >= 0.2 && < 0.3     , monads-tf >= 0.1 && < 0.2-    , libxml-sax >= 0.6 && < 0.7-    , xml-types >= 0.1 && < 0.2+    , libxml-sax >= 0.7 && < 0.8+    , xml-types >= 0.3 && < 0.4    exposed-modules:     Network.Protocol.XMPP