5 files changed, 76 insertions(+), 57 deletions(-)

M Network/Protocol/XMPP/Client.hs
M Network/Protocol/XMPP/Client/Authentication.hs
M Network/Protocol/XMPP/Component.hs
M Network/Protocol/XMPP/XML.hs
M network-protocol-xmpp.cabal

@@ 128,7 128,7 @@ bindStanza resource = (emptyIQ IQSet) { iqPayload = Just payload } where
 	requested = case fmap J.strResource resource of
 		Nothing -> []
 		Just x -> [X.NodeElement $ X.element "resource" []
-			[X.NodeContent $ X.ContentText x]]
+			[X.NodeContent $ X.ContentText (T.toStrict x)]]
 
 sessionStanza :: IQ
 sessionStanza = (emptyIQ IQSet) { iqPayload = Just payload } where

@@ 79,7 79,7 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
 			(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]
+				[X.NodeContent $ X.ContentText $ T.pack $ B.unpack b64text]
 			
 			case rc of
 				SASL.Complete -> saslFinish ctx


@@ 103,7 103,7 @@ saslLoop ctx = do
 	
 	(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]
+		[] [X.NodeContent $ X.ContentText $ T.pack $ B.unpack b64text]
 	case rc of
 		SASL.Complete -> saslFinish ctx
 		SASL.NeedsMore -> saslLoop ctx

@@ 24,6 24,7 @@ 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
 import qualified Data.Text.Lazy as T
 import qualified Data.Text.Lazy.Encoding as TE
 import Network (connectTo)


@@ 81,7 82,7 @@ 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
 
-showDigest :: B.ByteString -> T.Text
-showDigest = T.pack . concatMap wordToHex . B.unpack where
+showDigest :: B.ByteString -> Data.Text.Text
+showDigest = Data.Text.pack . concatMap wordToHex . B.unpack where
 	wordToHex x = [hexDig $ shiftR x 4, hexDig $ x .&. 0xF]
 	hexDig = intToDigit . fromIntegral

@@ 15,7 15,17 @@
 
 {-# LANGUAGE OverloadedStrings #-}
 module Network.Protocol.XMPP.XML
-	( module Data.XML.Types
+	( Element(..)
+	, Node(..)
+	, Content(..)
+	, Name(Name)
+	, Network.Protocol.XMPP.XML.nameNamespace
+	, Network.Protocol.XMPP.XML.nameLocalName
+	, isNamed
+	, elementChildren
+	, isContent
+	, attributeName
+	, Network.Protocol.XMPP.XML.attributeText
 	
 	-- * Constructors
 	, name


@@ 26,7 36,6 @@ module Network.Protocol.XMPP.XML
 	-- * Misc
 	, getattr
 	, contentText
-	, attributeText
 	, escape
 	, serialiseElement
 	, readEvents


@@ 40,85 49,93 @@ module Network.Protocol.XMPP.XML
 	
 	) where
 import Control.Monad (when)
-import qualified Data.ByteString.Lazy as B
-import qualified Data.Text.Lazy as T
-import Data.XML.Types
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text.Lazy as TL
+import Data.XML.Types as X
 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
+getattr :: Name -> Element -> Maybe TL.Text
+getattr n e = fmap TL.fromStrict (X.attributeText n e)
 
-contentText :: Content -> T.Text
-contentText (ContentText t) = t
-contentText (ContentEntity e) = T.concat ["&", e, ";"]
+contentText :: Content -> TL.Text
+contentText (ContentText t) = TL.fromStrict t
+contentText (ContentEntity e) = TL.concat ["&", TL.fromStrict e, ";"]
 
-attributeText :: Attribute -> T.Text
-attributeText = T.concat . map contentText . attributeContent
+name :: TL.Text -> Name
+name t = Name (TL.toStrict t) Nothing Nothing
 
-name :: T.Text -> Name
-name t = Name t Nothing Nothing
+nsname :: TL.Text -> TL.Text -> Name
+nsname ns n = Name (TL.toStrict n) (Just (TL.toStrict ns)) 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
+escape :: TL.Text -> TL.Text
+escape = TL.concatMap escapeChar where
 	escapeChar c = case c of
 		'&' -> "&"
 		'<' -> "&lt;"
 		'>' -> "&gt;"
 		'"' -> "&quot;"
 		'\'' -> "&apos;"
-		_ -> T.singleton c
+		_ -> TL.singleton c
 
-escapeContent :: Content -> T.Text
-escapeContent (ContentText t) = escape t
-escapeContent (ContentEntity e) = T.concat ["&", escape e, ";"]
+escapeContent :: Content -> TL.Text
+escapeContent (ContentText t) = escape (TL.fromStrict t)
+escapeContent (ContentEntity e) = TL.concat ["&", escape (TL.fromStrict e), ";"]
 
-element :: T.Text -> [(T.Text, T.Text)] -> [Node] -> Element
+element :: TL.Text -> [(TL.Text, TL.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 :: TL.Text -> TL.Text -> [(TL.Text, TL.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]
+mkattr :: TL.Text -> TL.Text -> (Name, [Content])
+mkattr n val = (name n, [ContentText (TL.toStrict val)])
 
 -- A somewhat primitive serialisation function
 --
 -- TODO: better namespace / prefix handling
-serialiseElement :: Element -> T.Text
+serialiseElement :: Element -> TL.Text
 serialiseElement e = text where
-	text = T.concat ["<", eName, " ", attrs, ">", contents, "</", eName, ">"]
+	text = TL.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
+	formatName = escape . TL.fromStrict . X.nameLocalName
+	attrs = TL.intercalate " " $ map attr $ elementAttributes e ++ nsattr
+	attr (n, c) = TL.concat $ [formatName n, "=\""] ++ map escapeContent c ++ ["\""]
+	nsattr = case X.nameNamespace $ elementName e of
 		Nothing -> []
-		Just ns -> [mkattr "xmlns" ns]
-	contents = T.concat $ map serialiseNode $ elementNodes e
+		Just ns -> [mkattr "xmlns" (TL.fromStrict ns)]
+	contents = TL.concat $ map serialiseNode $ elementNodes e
 	
 	serialiseNode (NodeElement e') = serialiseElement e'
 	serialiseNode (NodeContent c) = escape (contentText c)
 	serialiseNode (NodeComment _) = ""
 	serialiseNode (NodeInstruction _) = ""
 
+-- lazy wrappers around strict xml-types; avoids having to break the API just
+-- to use xml-types 0.3
+nameNamespace :: Name -> Maybe TL.Text
+nameNamespace = fmap TL.fromStrict . X.nameNamespace
+
+nameLocalName :: Name -> TL.Text
+nameLocalName = TL.fromStrict . X.nameLocalName
+
+attributeName :: (Name, [Content]) -> Name
+attributeName = fst
+
+attributeText :: (Name, [Content]) -> TL.Text
+attributeText = TL.concat . map contentText . snd
+
 -- 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 TL.Text [SaxEvent]))
 
 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


@@ 129,16 146,17 @@ newParser = do
 	
 	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.parsedCharacters (\txt -> addEvent $ Characters $ TL.fromStrict txt)
+	SAX.setCallback p SAX.parsedComment (\txt -> addEvent $ Comment $ TL.fromStrict txt)
 	SAX.setCallback p SAX.parsedInstruction (\i -> addEvent $ ProcessingInstruction i)
+	SAX.setCallback p SAX.reportError (\err -> writeIORef ref (Left $ TL.fromStrict err) >> return False)
 	
 	return $ Parser p ref
 
-parse :: Parser -> B.ByteString -> Bool -> IO (Either T.Text [SaxEvent])
+parse :: Parser -> BL.ByteString -> Bool -> IO (Either TL.Text [SaxEvent])
 parse (Parser p ref) bytes finish = do
 	writeIORef ref (Right [])
-	SAX.parseLazyBytes p bytes
+	SAX.parseBytes p (B.concat (BL.toChunks bytes))
 	when finish $ SAX.parseComplete p
 	eitherEvents <- readIORef ref
 	return $ case eitherEvents of


@@ 146,10 164,10 @@ parse (Parser p ref) bytes finish = do
 		Right events -> Right $ reverse events
 
 data SaxEvent
-	= BeginElement Name [Attribute]
+	= BeginElement Name [(Name, [Content])]
 	| EndElement Name
-	| Characters T.Text
-	| Comment T.Text
+	| Characters TL.Text
+	| Comment TL.Text
 	| ProcessingInstruction Instruction
 
 readEvents :: Monad m


@@ 209,7 227,7 @@ 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)]
+		(Characters t, _) -> [NodeContent (ContentText (TL.toStrict t))]
 		_ -> []
 	
 	node n as = NodeElement $ Element n as $ eventsToNodes $ init rest

@@ 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 @@ library
     , 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