10 files changed, 76 insertions(+), 81 deletions(-)

M examples/echo.hs
M lib/Network/Protocol/XMPP/Client/Authentication.hs
M lib/Network/Protocol/XMPP/Client/Features.hs
M lib/Network/Protocol/XMPP/Connections.hs
M lib/Network/Protocol/XMPP/ErrorT.hs
M lib/Network/Protocol/XMPP/Handle.hs
M lib/Network/Protocol/XMPP/JID.hs
M lib/Network/Protocol/XMPP/Monad.hs
M lib/Network/Protocol/XMPP/Stanza.hs
M lib/Network/Protocol/XMPP/XML.hs

@@ 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.

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

@@ 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"

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

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

@@ 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))

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

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

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

@@ 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]