~singpolyma/network-protocol-xmpp

bd96ff0c22e3b5c4688cee08c25380aab285ff6f — John Millikin 9 years ago 6ac34f1
Use the IsString instance of Name.
M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +4 -4
@@ 96,7 96,7 @@ bindJID jid = do
	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


@@ 126,7 126,7 @@ bindJID jid = do

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" []


@@ 134,7 134,7 @@ bindStanza resource = (emptyIQ IQSet) { iqPayload = Just payload } where

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


@@ 142,7 142,7 @@ streamSupportsTLS = any isStartTLS where
	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 ()

M Network/Protocol/XMPP/Client/Authentication.hs => Network/Protocol/XMPP/Client/Authentication.hs +4 -4
@@ 79,7 79,7 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
			SASL.setProperty SASL.PropertyHostname $ utf8 hostname
			
			(b64text, rc) <- SASL.step64 $ B.pack ""
			putElement ctx $ X.nselement "urn:ietf:params:xml:ns:xmpp-sasl" "auth"
			putElement ctx $ X.element "{urn:ietf:params:xml:ns:xmpp-sasl}auth"
				[("mechanism", TL.pack $ B.unpack mechBytes)]
				[X.NodeContent $ X.ContentText $ T.pack $ B.unpack b64text]
			


@@ 94,7 94,7 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
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


@@ 104,7 104,7 @@ saslLoop ctx = do
	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"
	putElement ctx $ X.element "{urn:ietf:params:xml:ns:xmpp-sasl}response"
		[] [X.NodeContent $ X.ContentText $ T.pack $ B.unpack b64text]
	case rc of
		SASL.Complete -> saslFinish ctx


@@ 113,7 113,7 @@ saslLoop ctx = do
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


M Network/Protocol/XMPP/Client/Features.hs => Network/Protocol/XMPP/Client/Features.hs +2 -2
@@ 64,7 64,7 @@ parseFeatureSASL e = FeatureSASL $
	>>= return . B.pack . TL.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"

M Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +2 -2
@@ 67,7 67,7 @@ parseStreamID (X.BeginElement _ attrs) = sid where
		(x:_) -> Just . X.attributeText $ x
		_ -> Nothing
	idAttrs = filter (matchingName . X.attributeName) attrs
	matchingName = (== X.Name "jid" (Just "jabber:component:accept") Nothing)
	matchingName = (== "{jabber:component:accept}jid")
parseStreamID _ = Nothing

authenticate :: T.Text -> T.Text -> M.XMPP ()


@@ 76,7 76,7 @@ authenticate streamID password = do
	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
	let nameHandshake = "{jabber:component:accept}handshake"
	when (null (X.isNamed nameHandshake result)) $
		throwError M.AuthenticationFailure


M Network/Protocol/XMPP/Connections.hs => Network/Protocol/XMPP/Connections.hs +1 -1
@@ 56,4 56,4 @@ startOfStream depth event = case (depth, event) of
	_ -> False

qnameStream :: X.Name
qnameStream = X.Name "stream" (Just "http://etherx.jabber.org/streams") Nothing
qnameStream = "{http://etherx.jabber.org/streams}stream"

M Network/Protocol/XMPP/Stanza.hs => Network/Protocol/XMPP/Stanza.hs +12 -12
@@ 184,7 184,7 @@ emptyIQ t = IQ
	, iqPayload = Nothing
	}

stanzaToElement' :: Stanza a => a -> T.Text -> T.Text -> X.Element
stanzaToElement' :: Stanza a => a -> X.Name -> T.Text -> X.Element
stanzaToElement' stanza name typeStr = X.element name attrs payloads where
	payloads = map X.NodeElement $ stanzaPayloads stanza
	attrs = concat


@@ 212,7 212,7 @@ elementToStanza ns elemt = do

parseMessage :: X.Element -> Maybe Message
parseMessage elemt = do
	typeStr <- X.getattr (X.name "type") elemt
	typeStr <- X.getattr "type" elemt
	msgType <- case typeStr of
		"normal"    -> Just MessageNormal
		"chat"      -> Just MessageChat


@@ 222,14 222,14 @@ parseMessage elemt = do
		_           -> 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.getattr "id" elemt
	let msgLang = X.getattr "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
	let typeStr = maybe "" id $ X.getattr "type" elemt
	pType <- case typeStr of
		""             -> Just PresenceAvailable
		"unavailable"  -> Just PresenceUnavailable


@@ 243,14 243,14 @@ parsePresence elemt = do
		
	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.getattr "id" elemt
	let msgLang = X.getattr "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
	typeStr <- X.getattr "type" elemt
	iqType <- case typeStr of
		"get"    -> Just IQGet
		"set"    -> Just IQSet


@@ 260,15 260,15 @@ parseIQ elemt = do
	
	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.getattr "id" elemt
	let msgLang = X.getattr "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
xmlJID :: X.Name -> X.Element -> Maybe (Maybe JID)
xmlJID name elemt = case X.getattr name elemt of
	Nothing -> Just Nothing
	Just raw -> case parseJID raw of
		Just jid -> Just (Just jid)

M Network/Protocol/XMPP/XML.hs => Network/Protocol/XMPP/XML.hs +4 -17
@@ 29,10 29,7 @@ module Network.Protocol.XMPP.XML
	, Network.Protocol.XMPP.XML.attributeText
	
	-- * Constructors
	, name
	, nsname
	, element
	, nselement
	
	-- * Misc
	, getattr


@@ 65,12 62,6 @@ contentText :: Content -> TL.Text
contentText (ContentText t) = TL.fromStrict t
contentText (ContentEntity e) = TL.concat ["&", TL.fromStrict e, ";"]

name :: TL.Text -> Name
name t = Name (TL.toStrict t) Nothing Nothing

nsname :: TL.Text -> TL.Text -> Name
nsname ns n = Name (TL.toStrict n) (Just (TL.toStrict ns)) Nothing

escape :: TL.Text -> TL.Text
escape = TL.concatMap escapeChar where
	escapeChar c = case c of


@@ 85,16 76,12 @@ escapeContent :: Content -> TL.Text
escapeContent (ContentText t) = escape (TL.fromStrict t)
escapeContent (ContentEntity e) = TL.concat ["&", escape (TL.fromStrict e), ";"]

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 :: TL.Text -> TL.Text -> [(TL.Text, TL.Text)] -> [Node] -> Element
nselement ns ln attrs children = Element (nsname ns ln) attrs' children where
element :: Name -> [(Name, TL.Text)] -> [Node] -> Element
element name attrs children = Element name attrs' children where
	attrs' = map (uncurry mkattr) attrs

mkattr :: TL.Text -> TL.Text -> (Name, [Content])
mkattr n val = (name n, [ContentText (TL.toStrict val)])
mkattr :: Name -> TL.Text -> (Name, [Content])
mkattr n val = (n, [ContentText (TL.toStrict val)])

-- A somewhat primitive serialisation function
--