~singpolyma/network-protocol-xmpp

0af7ade041bb4acdd8fdba68230dc6ff67ba794b — Stephen Paul Weber 2 years ago 4a70077
hlint clean
M examples/echo.hs => examples/echo.hs +5 -5
@@ 45,8 45,8 @@ runEcho hostname user password = do
		Nothing -> error $ "Invalid JID: " ++ show user
	username <- case strNode `fmap` jidNode jid of
		Just x -> return x
		Nothing -> error $ "JID must include a username"
	
		Nothing -> error "JID must include a username"

	-- 'Server' values record what host the connection will be opened to. Normally
	-- the hostname and JID will be the same; however, in some cases the hostname is
	-- something special (like "jabber.domain.com" or "localhost").


@@ 96,9 96,9 @@ runEcho hostname user password = do
				ReceivedMessage msg -> if messageType msg == MessageError
					then return ()
					else putStanza $ echo msg
				ReceivedPresence msg -> if presenceType msg == PresenceSubscribe
					then putStanza (subscribe msg)
					else return ()
				ReceivedPresence msg ->
					when (presenceType msg == PresenceSubscribe) $
						putStanza (subscribe msg)
				_ -> return ()

	-- If 'runClient' terminated due to an XMPP error, propagate it as an exception.

M lib/Network/Protocol/XMPP/Client/Authentication.hs => lib/Network/Protocol/XMPP/Client/Authentication.hs +2 -2
@@ 92,7 92,7 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
saslLoop :: M.Session -> SASL.Session Result
saslLoop ctx = do
	e <- getElement ctx
	let challengeTexts = X.elementNodes e >>= X.isContent >>= return . X.contentText
	let challengeTexts = X.contentText <$> (X.elementNodes e >>= X.isContent)
	let challenge = concatMap Data.Text.unpack challengeTexts
	case X.elementName e of
		-- The server needs more data before it can authenticate this client.


@@ 119,7 119,7 @@ saslLoop ctx = do
		-- The server has rejected this client's credentials.
		n | n == "{urn:ietf:params:xml:ns:xmpp-sasl}failure" -> return (Failure e)

		_ -> saslError ("Server sent unexpected element during authentication.")
		_ -> saslError "Server sent unexpected element during authentication."

saslFinish :: M.Session -> SASL.Session Result
saslFinish ctx = do

M lib/Network/Protocol/XMPP/Client/Features.hs => lib/Network/Protocol/XMPP/Client/Features.hs +5 -5
@@ 21,6 21,7 @@ module Network.Protocol.XMPP.Client.Features
	, parseFeature
	) where

import           Data.Maybe (fromMaybe)
import           Control.Arrow ((&&&))
import qualified Data.ByteString.Char8
import           Data.ByteString (ByteString)


@@ 38,13 39,12 @@ data Feature =

parseFeatures :: X.Element -> [Feature]
parseFeatures e =
	X.isNamed nameFeatures e
	>>= X.elementChildren
	>>= return . parseFeature
	parseFeature <$>
	(X.isNamed nameFeatures e >>= X.elementChildren)

parseFeature :: X.Element -> Feature
parseFeature elemt = feature where
	unpackName = (maybe "" id . X.nameNamespace) &&& X.nameLocalName
	unpackName = (fromMaybe "" . 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


@@ 58,11 58,11 @@ parseFeatureTLS _ = FeatureStartTLS True -- TODO: detect whether or not required

parseFeatureSASL :: X.Element -> Feature
parseFeatureSASL e = FeatureSASL $
	fmap (Data.ByteString.Char8.pack . Data.Text.unpack . X.contentText) $
	X.elementChildren e
	>>= X.isNamed nameMechanism
	>>= X.elementNodes
	>>= X.isContent
	>>= return . Data.ByteString.Char8.pack . Data.Text.unpack . X.contentText

nameMechanism :: X.Name
nameMechanism = "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism"

M lib/Network/Protocol/XMPP/Connections.hs => lib/Network/Protocol/XMPP/Connections.hs +1 -1
@@ 53,7 53,7 @@ xmlHeader ns jid = encodeUtf8 header where

startOfStream :: Integer -> X.Event -> Bool
startOfStream depth event = case (depth, event) of
	(1, (X.EventBeginElement elemName _)) -> qnameStream == elemName
	(1, X.EventBeginElement elemName _) -> qnameStream == elemName
	_ -> False

qnameStream :: X.Name

M lib/Network/Protocol/XMPP/ErrorT.hs => lib/Network/Protocol/XMPP/ErrorT.hs +1 -2
@@ 21,7 21,6 @@ module Network.Protocol.XMPP.ErrorT
	) where

import           Control.Applicative (Applicative, pure, (<*>))
import           Control.Monad (liftM)
import           Control.Monad.Fix (MonadFix, mfix)
import           Control.Monad.Trans (MonadIO, liftIO)
import           Control.Monad.Trans.Class (MonadTrans, lift)


@@ 67,7 66,7 @@ instance Monad m => E.MonadError (ErrorT e m) where
			Right r -> return (Right r)

instance MonadTrans (ErrorT e) where
	lift = ErrorT . liftM Right
	lift = ErrorT . fmap Right

instance R.MonadReader m => R.MonadReader (ErrorT e m) where
	type EnvType (ErrorT e m) = EnvType m

M lib/Network/Protocol/XMPP/Handle.hs => lib/Network/Protocol/XMPP/Handle.hs +2 -2
@@ 23,7 23,7 @@ module Network.Protocol.XMPP.Handle
	, handleIsSecure
	) where

import           Control.Monad (when)
import           Control.Monad (when, void)
import qualified Control.Monad.Error as E
import           Control.Monad.Trans (liftIO)
import qualified Data.ByteString


@@ 65,7 65,7 @@ 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 ()
	let wait = void $ IO.hWaitForInput h (- 1)
	when (pending == 0) (liftIO wait)
	lazy <- TLS.getBytes n
	return (Data.ByteString.concat (Data.ByteString.Lazy.toChunks lazy))

M lib/Network/Protocol/XMPP/JID.hs => lib/Network/Protocol/XMPP/JID.hs +2 -3
@@ 27,6 27,7 @@ module Network.Protocol.XMPP.JID
	, formatJID
	) where

import           Data.Maybe (fromMaybe)
import qualified Data.Text
import           Data.Text (Text)
import qualified Data.Text.IDN.StringPrep as SP


@@ 97,9 98,7 @@ parseJID str = maybeJID where
		Right y -> Just y

parseJID_ :: Text -> JID
parseJID_ text = case parseJID text of
	Just jid -> jid
	Nothing -> error "Malformed JID"
parseJID_ = fromMaybe (error "Malformed JID") . parseJID

formatJID :: JID -> Text
formatJID (JID node (Domain domain) resource) = formatted where

M lib/Network/Protocol/XMPP/Monad.hs => lib/Network/Protocol/XMPP/Monad.hs +3 -4
@@ 37,6 37,7 @@ module Network.Protocol.XMPP.Monad
	, putStanza
	) where

import           Data.Maybe (fromMaybe)
import qualified Control.Applicative as A
import qualified Control.Concurrent.MVar as M
import           Control.Monad (ap)


@@ 127,7 128,7 @@ restartXMPP :: Maybe H.Handle -> XMPP a -> XMPP a
restartXMPP newH xmpp = do
	Session oldH ns _ readLock writeLock <- getSession
	sax <- liftIO X.newParser
	let s = Session (maybe oldH id newH) ns sax readLock writeLock
	let s = Session (fromMaybe oldH newH) ns sax readLock writeLock
	XMPP (R.local (const s) (unXMPP xmpp))

withLock :: (Session -> M.MVar ()) -> XMPP a -> XMPP a


@@ 146,9 147,7 @@ getHandle :: XMPP H.Handle
getHandle = fmap sessionHandle getSession

sessionIsSecure :: XMPP Bool
sessionIsSecure = do
	h <- getHandle
	return (H.handleIsSecure h)
sessionIsSecure = H.handleIsSecure <$> getHandle

liftTLS :: ErrorT Text IO a -> XMPP a
liftTLS io = do

M lib/Network/Protocol/XMPP/Stanza.hs => lib/Network/Protocol/XMPP/Stanza.hs +49 -50
@@ 33,7 33,7 @@ module Network.Protocol.XMPP.Stanza
	, elementToStanza
	) where

import           Data.Maybe (fromMaybe)
import           Data.Maybe (listToMaybe)
import           Control.Monad (when)
import qualified Data.Text
import           Data.Text (Text)


@@ 212,61 212,60 @@ elementToStanza ns elemt = do
		"iq" -> ReceivedIQ `fmap` parseIQ elemt
		_ -> Nothing

parseStanzaCommon ::
	   (Maybe Text -> Maybe t)
	-> (t -> Maybe JID -> Maybe JID -> Maybe Text -> Maybe Text -> [X.Element] -> s)
	-> X.Element
	-> Maybe s
parseStanzaCommon parseType mk elemt = do
	to <- xmlJID "to" elemt
	from <- xmlJID "from" elemt
	typ <- parseType $ X.attributeText "type" elemt
	return $ mk
		typ
		to
		from
		(X.attributeText "id" elemt)
		(X.attributeText "lang" elemt)
		(X.elementChildren elemt)

parseMessage :: X.Element -> Maybe Message
parseMessage elemt = do
	msgType <- case fromMaybe "normal" $ X.attributeText "type" elemt 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.attributeText "id" elemt
	let msgLang = X.attributeText "lang" elemt
	let payloads = X.elementChildren elemt
	return (Message msgType msgTo msgFrom msgID msgLang payloads)
parseMessage =
	parseStanzaCommon parseType Message
	where
	parseType Nothing            = Just MessageNormal
	parseType (Just "normal")    = Just MessageNormal
	parseType (Just "chat")      = Just MessageChat
	parseType (Just "groupchat") = Just MessageGroupChat
	parseType (Just "headline")  = Just MessageHeadline
	parseType (Just "error")     = Just MessageError
	parseType (Just _)           = Nothing

parsePresence :: X.Element -> Maybe Presence
parsePresence elemt = do
	let typeStr = maybe "" id (X.attributeText "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.attributeText "id" elemt
	let msgLang = X.attributeText "lang" elemt
	let payloads = X.elementChildren elemt
	return (Presence pType msgTo msgFrom msgID msgLang payloads)
parsePresence =
	parseStanzaCommon parseType Presence
	where
	parseType Nothing               = Just PresenceAvailable
	parseType (Just "unavailable")  = Just PresenceUnavailable
	parseType (Just "subscribe")    = Just PresenceSubscribe
	parseType (Just "subscribed")   = Just PresenceSubscribed
	parseType (Just "unsubscribe")  = Just PresenceUnsubscribe
	parseType (Just "unsubscribed") = Just PresenceUnsubscribed
	parseType (Just "probe")        = Just PresenceProbe
	parseType (Just "error")        = Just PresenceError
	parseType (Just _)              = Nothing

parseIQ :: X.Element -> Maybe IQ
parseIQ elemt = do
	typeStr <- X.attributeText "type" elemt
	iqType <- case typeStr of
		"get"    -> Just IQGet
		"set"    -> Just IQSet
		"result" -> Just IQResult
		"error"  -> Just IQError
		_        -> Nothing
parseIQ =
	parseStanzaCommon parseType mk
	where
	mk a b c d e f = IQ a b c d e (listToMaybe f)

	msgTo <- xmlJID "to" elemt
	msgFrom <- xmlJID "from" 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)
	parseType (Just "get")    = Just IQGet
	parseType (Just "set")    = Just IQSet
	parseType (Just "result") = Just IQResult
	parseType (Just "error")  = Just IQError
	parseType _               = Nothing

xmlJID :: X.Name -> X.Element -> Maybe (Maybe JID)
xmlJID name elemt = case X.attributeText name elemt of

M lib/Network/Protocol/XMPP/XML.hs => lib/Network/Protocol/XMPP/XML.hs +6 -7
@@ 62,11 62,10 @@ escapeContent (ContentText t) = escape t
escapeContent (ContentEntity e) = Data.Text.concat ["&", escape e, ";"]

element :: Name -> [(Name, Text)] -> [Node] -> Element
element name attrs children = Element name attrs' children where
	attrs' = map (uncurry mkattr) attrs
element name attrs = Element name (map mkattr attrs)

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

-- A somewhat primitive serialisation function
--


@@ 80,7 79,7 @@ serialiseElement e = text where
	attr (n, c) = Data.Text.concat ([formatName n, "=\""] ++ map escapeContent c ++ ["\""])
	nsattr = case nameNamespace $ elementName e of
		Nothing -> []
		Just ns -> [mkattr "xmlns" ns]
		Just ns -> [mkattr ("xmlns", ns)]
	contents = Data.Text.concat (map serialiseNode (elementNodes e))

	serialiseNode (NodeElement e') = serialiseElement e'


@@ 139,7 138,7 @@ readEvents done nextEvents = readEvents' 0 [] where
	step (e:es) depth acc = let
		depth' = depth + case e of
			(EventBeginElement _ _) -> 1
			(EventEndElement _) -> (- 1)
			(EventEndElement _) -> -1
			_ -> 0
		acc' = e : acc
		in if done depth' e


@@ 171,7 170,7 @@ splitBlocks es = ret where
		depth' :: Integer
		depth' = depth + case e of
			(EventBeginElement _ _) -> 1
			(EventEndElement _) -> (- 1)
			(EventEndElement _) -> -1
			_ -> 0

blockToNodes :: [Event] -> [Node]