~singpolyma/network-protocol-xmpp

1ab0aa09cbc656f8c3b3f4d0802e330e8fe5c2ee — John Millikin 12 years ago 3be80c7
Quick-n-dirty port to updated xml-types and libxml-sax.
M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +1 -1
@@ 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

M Network/Protocol/XMPP/Client/Authentication.hs => Network/Protocol/XMPP/Client/Authentication.hs +2 -2
@@ 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

M Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +3 -2
@@ 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

M Network/Protocol/XMPP/XML.hs => Network/Protocol/XMPP/XML.hs +67 -49
@@ 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
		'&' -> "&amp;"
		'<' -> "&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

M network-protocol-xmpp.cabal => network-protocol-xmpp.cabal +3 -3
@@ 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