9 files changed, 82 insertions(+), 81 deletions(-)

M Network/Protocol/XMPP/Client.hs
M Network/Protocol/XMPP/Client/Authentication.hs
M Network/Protocol/XMPP/Component.hs
M Network/Protocol/XMPP/ErrorT.hs
M Network/Protocol/XMPP/Handle.hs
M Network/Protocol/XMPP/JID.hs
M Network/Protocol/XMPP/Monad.hs
M Network/Protocol/XMPP/Stanza.hs
M Network/Protocol/XMPP/XML.hs

@@ 61,7 61,7 @@ runClient server jid username password xmpp = do
 
 newStream :: J.JID -> M.XMPP [F.Feature]
 newStream jid = do
-	M.putBytes $ C.xmlHeader "jabber:client" jid
+	M.putBytes (C.xmlHeader "jabber:client" jid)
 	void (M.readEvents C.startOfStream)
 	F.parseFeatures `fmap` M.getElement
 


@@ 72,10 72,10 @@ tryTLS sjid features m
 		M.putElement xmlStartTLS
 		void M.getElement
 		h <- M.getHandle
-		eitherTLS <- liftIO $ runErrorT $ H.startTLS h
+		eitherTLS <- liftIO (runErrorT (H.startTLS h))
 		case eitherTLS of
-			Left err -> throwError $ M.TransportError err
-			Right tls -> M.restartXMPP (Just tls) $ newStream sjid >>= m
+			Left err -> throwError (M.TransportError err)
+			Right tls -> M.restartXMPP (Just tls) (newStream sjid >>= m)
 
 authenticationMechanisms :: [F.Feature] -> [ByteString]
 authenticationMechanisms = step where


@@ 92,7 92,7 @@ authenticationMechanisms = step where
 bindJID :: J.JID -> M.XMPP J.JID
 bindJID jid = do
 	-- Bind
-	M.putStanza . bindStanza . J.jidResource $ jid
+	M.putStanza (bindStanza (J.jidResource jid))
 	bindResult <- M.getStanza
 	let getJID =
 		X.elementChildren


@@ 113,13 113,13 @@ bindJID jid = do
 	
 	returnedJID <- case maybeJID of
 		Just x -> return x
-		Nothing -> throwError $ M.InvalidBindResult bindResult
+		Nothing -> throwError (M.InvalidBindResult bindResult)
 	
 	-- Session
 	M.putStanza sessionStanza
 	void M.getStanza
 	
-	M.putStanza $ emptyPresence PresenceAvailable
+	M.putStanza (emptyPresence PresenceAvailable)
 	void M.getStanza
 	
 	return returnedJID


@@ 129,8 129,7 @@ bindStanza resource = (emptyIQ IQSet) { iqPayload = Just payload } where
 	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" []
-			[X.NodeContent $ X.ContentText x]]
+		Just x -> [X.NodeElement (X.element "resource" [] [X.NodeContent (X.ContentText x)])]
 
 sessionStanza :: IQ
 sessionStanza = (emptyIQ IQSet) { iqPayload = Just payload } where

@@ 25,7 25,8 @@ import qualified Control.Exception as Exc
 import           Control.Monad (when, (>=>))
 import           Control.Monad.IO.Class (MonadIO, liftIO)
 import qualified Control.Monad.Error as E
-import qualified Data.ByteString.Char8 as B
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8
 import qualified Data.Text
 import           Data.Text (Text)
 import           Data.Text.Encoding (encodeUtf8)


@@ 44,7 45,7 @@ data AuthException = XmppError M.Error | SaslError Text
 
 instance Exc.Exception AuthException
 
-authenticate :: [B.ByteString] -- ^ Mechanisms
+authenticate :: [ByteString] -- ^ Mechanisms
              -> JID -- ^ User JID
              -> JID -- ^ Server JID
              -> Text -- ^ Username


@@ 52,12 53,12 @@ authenticate :: [B.ByteString] -- ^ Mechanisms
              -> M.XMPP ()
 authenticate xmppMechanisms userJID serverJID username password = xmpp where
 	mechanisms = map SASL.Mechanism xmppMechanisms
-	authz = formatJID $ userJID { jidResource = Nothing }
+	authz = formatJID (userJID { jidResource = Nothing })
 	hostname = formatJID serverJID
 	
 	xmpp = do
 		ctx <- M.getSession
-		res <- liftIO $ Exc.try $ SASL.runSASL $ do
+		res <- liftIO . Exc.try . SASL.runSASL $ do
 			suggested <- SASL.clientSuggestMechanism mechanisms
 			case suggested of
 				Nothing -> saslError "No supported authentication mechanism"


@@ 66,21 67,21 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
 			Right Success -> return ()
 			Right Failure -> E.throwError M.AuthenticationFailure
 			Left (XmppError err) -> E.throwError err
-			Left (SaslError err) -> E.throwError $ M.AuthenticationError err
+			Left (SaslError err) -> E.throwError (M.AuthenticationError err)
 	
 	authSasl ctx mechanism = do
 		let (SASL.Mechanism mechBytes) = mechanism
 		sessionResult <- SASL.runClient mechanism $ do
-			SASL.setProperty SASL.PropertyAuthzID $ encodeUtf8 authz
-			SASL.setProperty SASL.PropertyAuthID $ encodeUtf8 username
-			SASL.setProperty SASL.PropertyPassword $ encodeUtf8 password
-			SASL.setProperty SASL.PropertyService $ B.pack "xmpp"
-			SASL.setProperty SASL.PropertyHostname $ encodeUtf8 hostname
+			SASL.setProperty SASL.PropertyAuthzID (encodeUtf8 authz)
+			SASL.setProperty SASL.PropertyAuthID (encodeUtf8 username)
+			SASL.setProperty SASL.PropertyPassword (encodeUtf8 password)
+			SASL.setProperty SASL.PropertyService "xmpp"
+			SASL.setProperty SASL.PropertyHostname (encodeUtf8 hostname)
 			
-			(b64text, rc) <- SASL.step64 $ B.pack ""
+			(b64text, rc) <- SASL.step64 ""
 			putElement ctx $ X.element "{urn:ietf:params:xml:ns:xmpp-sasl}auth"
-				[("mechanism", Data.Text.pack $ B.unpack mechBytes)]
-				[X.NodeContent $ X.ContentText $ Data.Text.pack $ B.unpack b64text]
+				[("mechanism", Data.Text.pack (Data.ByteString.Char8.unpack mechBytes))]
+				[X.NodeContent (X.ContentText (Data.Text.pack (Data.ByteString.Char8.unpack b64text)))]
 			
 			case rc of
 				SASL.Complete -> saslFinish ctx


@@ 88,7 89,7 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
 			
 		case sessionResult of
 			Right x -> return x
-			Left err -> saslError $ Data.Text.pack $ show err
+			Left err -> saslError (Data.Text.pack (show err))
 
 saslLoop :: M.Session -> SASL.Session Result
 saslLoop ctx = do


@@ 100,11 101,11 @@ saslLoop ctx = do
 		>=> X.isContent
 		>=> return . X.contentText
 	let challengeText = getChallengeText elemt
-	when (null challengeText) $ saslError "Received empty challenge"
+	when (null challengeText) (saslError "Received empty challenge")
 	
-	(b64text, rc) <- SASL.step64 . B.pack . concatMap Data.Text.unpack $ challengeText
+	(b64text, rc) <- SASL.step64 (Data.ByteString.Char8.pack (concatMap Data.Text.unpack challengeText))
 	putElement ctx $ X.element "{urn:ietf:params:xml:ns:xmpp-sasl}response"
-		[] [X.NodeContent $ X.ContentText $ Data.Text.pack $ B.unpack b64text]
+		[] [X.NodeContent (X.ContentText (Data.Text.pack (Data.ByteString.Char8.unpack b64text)))]
 	case rc of
 		SASL.Complete -> saslFinish ctx
 		SASL.NeedsMore -> saslLoop ctx


@@ 114,20 115,20 @@ saslFinish ctx = do
 	elemt <- getElement ctx
 	let name = "{urn:ietf:params:xml:ns:xmpp-sasl}success"
 	let success = X.isNamed name elemt
-	return $ if null success then Failure else Success
+	return (if null success then Failure else Success)
 
 putElement :: M.Session -> X.Element -> SASL.Session ()
 putElement ctx elemt = liftIO $ do
-	res <- M.runXMPP ctx $ M.putElement elemt
+	res <- M.runXMPP ctx (M.putElement elemt)
 	case res of
-		Left err -> Exc.throwIO $ XmppError err
+		Left err -> Exc.throwIO (XmppError err)
 		Right x -> return x
 
 getElement :: M.Session -> SASL.Session X.Element
 getElement ctx = liftIO $ do
 	res <- M.runXMPP ctx M.getElement
 	case res of
-		Left err -> Exc.throwIO $ XmppError err
+		Left err -> Exc.throwIO (XmppError err)
 		Right x -> return x
 
 saslError :: MonadIO m => Text -> m a

@@ 70,17 70,16 @@ parseStreamID _ = Nothing
 authenticate :: Text -> Text -> M.XMPP ()
 authenticate streamID password = do
 	let bytes = buildSecret streamID password
-	let digest = showDigest $ sha1 bytes
-	M.putElement $ X.element "handshake" [] [X.NodeContent $ X.ContentText digest]
+	let digest = showDigest (sha1 bytes)
+	M.putElement (X.element "handshake" [] [X.NodeContent (X.ContentText digest)])
 	result <- M.getElement
 	let nameHandshake = "{jabber:component:accept}handshake"
-	when (null (X.isNamed nameHandshake result)) $
-		throwError M.AuthenticationFailure
+	when (null (X.isNamed nameHandshake result)) (throwError M.AuthenticationFailure)
 
 buildSecret :: Text -> Text -> ByteString
 buildSecret sid password = encodeUtf8 (X.escape (Data.Text.append sid password))
 
 showDigest :: ByteString -> Text
 showDigest = Data.Text.pack . concatMap wordToHex . Data.ByteString.unpack where
-	wordToHex x = [hexDig $ shiftR x 4, hexDig $ x .&. 0xF]
+	wordToHex x = [hexDig (shiftR x 4), hexDig (x .&. 0xF)]
 	hexDig = intToDigit . fromIntegral

@@ 39,8 39,8 @@ instance Monad m => Monad (ErrorT e m) where
 	(>>=) m k = ErrorT $ do
 		x <- runErrorT m
 		case x of
-			Left l -> return $ Left l
-			Right r -> runErrorT $ k r
+			Left l -> return (Left l)
+			Right r -> runErrorT (k r)
 
 instance Monad m => E.MonadError (ErrorT e m) where
 	type E.ErrorType (ErrorT e m) = e


@@ 48,8 48,8 @@ instance Monad m => E.MonadError (ErrorT e m) where
 	catchError m h = ErrorT $ do
 		x <- runErrorT m
 		case x of
-			Left l -> runErrorT $ h l
-			Right r -> return $ Right r
+			Left l -> runErrorT (h l)
+			Right r -> return (Right r)
 
 instance MonadTrans (ErrorT e) where
 	lift = ErrorT . liftM Right


@@ 70,4 70,4 @@ instance MonadFix m => MonadFix (ErrorT e m) where
 mapErrorT :: (m (Either e a) -> n (Either e' b))
            -> ErrorT e m a
            -> ErrorT e' n b
-mapErrorT f m = ErrorT $ f (runErrorT m)
+mapErrorT f m = ErrorT (f (runErrorT m))

@@ 45,7 45,7 @@ liftTLS' :: IO (Either TLS.Error a) -> ErrorT Text IO a
 liftTLS' io = do
 	eitherX <- liftIO io
 	case eitherX of
-		Left err -> E.throwError $ Data.Text.pack $ show err
+		Left err -> E.throwError (Data.Text.pack (show err))
 		Right x -> return x
 
 startTLS :: Handle -> ErrorT Text IO Handle


@@ 62,7 62,7 @@ hPutBytes (SecureHandle _ s) = liftTLS s . TLS.putBytes . toLazy where
 	toLazy bytes = Data.ByteString.Lazy.fromChunks [bytes]
 
 hGetBytes :: Handle -> Integer -> ErrorT Text IO ByteString
-hGetBytes (PlainHandle h) n = liftIO $ Data.ByteString.hGet h $ fromInteger n
+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 ()

@@ 81,11 81,13 @@ parseJID str = maybeJID where
 		(x, y) -> if Data.Text.null y
 			then (x, "")
 			else (x, Data.Text.drop 1 y)
-	nullable x f = if Data.Text.null x then Just Nothing else fmap Just $ f x
+	nullable x f = if Data.Text.null x
+		then Just Nothing
+		else fmap Just (f x)
 	maybeJID = do
-		preppedNode <- nullable node $ stringprepM SP.xmppNode
+		preppedNode <- nullable node (stringprepM SP.xmppNode)
 		preppedDomain <- stringprepM SP.nameprep domain
-		preppedResource <- nullable resource $ stringprepM SP.xmppResource
+		preppedResource <- nullable resource (stringprepM SP.xmppResource)
 		return $ JID
 			(fmap Node preppedNode)
 			(Domain preppedDomain)

@@ 90,7 90,7 @@ instance Functor XMPP where
 
 instance Monad XMPP where
 	return = XMPP . return
-	m >>= f = XMPP $ unXMPP m >>= unXMPP . f
+	m >>= f = XMPP (unXMPP m >>= unXMPP . f)
 
 instance MonadIO XMPP where
 	liftIO = XMPP . liftIO


@@ 98,14 98,14 @@ instance MonadIO XMPP where
 instance E.MonadError XMPP where
 	type E.ErrorType XMPP = Error
 	throwError = XMPP . E.throwError
-	catchError m h = XMPP $ E.catchError (unXMPP m) (unXMPP . h)
+	catchError m h = XMPP (E.catchError (unXMPP m) (unXMPP . h))
 
 instance A.Applicative XMPP where
 	pure = return
 	(<*>) = ap
 
 instance MonadFix XMPP where
-	mfix f = XMPP $ mfix $ unXMPP . f
+	mfix f = XMPP (mfix (unXMPP . f))
 
 runXMPP :: Session -> XMPP a -> IO (Either Error a)
 runXMPP s xmpp = R.runReaderT (runErrorT (unXMPP xmpp)) s


@@ 120,15 120,15 @@ startXMPP h ns xmpp = do
 restartXMPP :: Maybe H.Handle -> XMPP a -> XMPP a
 restartXMPP newH xmpp = do
 	Session oldH ns _ readLock writeLock <- getSession
-	sax <- liftIO $ X.newParser
+	sax <- liftIO X.newParser
 	let s = Session (maybe oldH id newH) ns sax readLock writeLock
-	XMPP $ R.local (const s) (unXMPP xmpp)
+	XMPP (R.local (const s) (unXMPP xmpp))
 
 withLock :: (Session -> M.MVar ()) -> XMPP a -> XMPP a
 withLock getLock xmpp = do
 	s <- getSession
 	let mvar = getLock s
-	res <- liftIO $ M.withMVar mvar $ \_ -> runXMPP s xmpp
+	res <- liftIO (M.withMVar mvar (\_ -> runXMPP s xmpp))
 	case res of
 		Left err -> E.throwError err
 		Right x -> return x


@@ 141,15 141,15 @@ getHandle = fmap sessionHandle getSession
 
 liftTLS :: ErrorT Text IO a -> XMPP a
 liftTLS io = do
-	res <- liftIO $ runErrorT io
+	res <- liftIO (runErrorT io)
 	case res of
-		Left err -> E.throwError $ TransportError err
+		Left err -> E.throwError (TransportError err)
 		Right x -> return x
 
 putBytes :: ByteString -> XMPP ()
 putBytes bytes = do
 	h <- getHandle
-	liftTLS $ H.hPutBytes h bytes
+	liftTLS (H.hPutBytes h bytes)
 
 putElement :: X.Element -> XMPP ()
 putElement = putBytes . encodeUtf8 . X.serialiseElement


@@ 163,11 163,11 @@ readEvents done = xmpp where
 		Session h _ p _ _ <- getSession
 		let nextEvents = do
 			-- TODO: read in larger increments
-			bytes <- liftTLS $ H.hGetBytes h 1
-			let eof = Data.ByteString.length bytes == 0
-			parsed <- liftIO $ X.parse p bytes eof
+			bytes <- liftTLS (H.hGetBytes h 1)
+			let eof = Data.ByteString.null bytes
+			parsed <- liftIO (X.parse p bytes eof)
 			case parsed of
-				Left err -> E.throwError $ TransportError err
+				Left err -> E.throwError (TransportError err)
 				Right events -> return events
 		X.readEvents done nextEvents
 


@@ 177,7 177,7 @@ getElement = xmpp where
 		events <- readEvents endOfTree
 		case X.eventsToElement events of
 			Just x -> return x
-			Nothing -> E.throwError $ TransportError "getElement: invalid event list"
+			Nothing -> E.throwError (TransportError "getElement: invalid event list")
 	
 	endOfTree 0 (X.EventEndElement _) = True
 	endOfTree _ _ = False


@@ 188,4 188,4 @@ getStanza = withLock sessionReadLock $ do
 	Session _ ns _ _ _ <- getSession
 	case S.elementToStanza ns elemt of
 		Just x -> return x
-		Nothing -> E.throwError $ InvalidStanza elemt
+		Nothing -> E.throwError (InvalidStanza elemt)

@@ 187,10 187,10 @@ emptyIQ t = IQ
 
 stanzaToElement' :: Stanza a => a -> X.Name -> Text -> X.Element
 stanzaToElement' stanza name typeStr = X.element name attrs payloads where
-	payloads = map X.NodeElement $ stanzaPayloads stanza
+	payloads = map X.NodeElement (stanzaPayloads stanza)
 	attrs = concat
-		[ mattr "to" $ fmap formatJID . stanzaTo
-		, mattr "from" $ fmap formatJID . stanzaFrom
+		[ mattr "to" (fmap formatJID . stanzaTo)
+		, mattr "from" (fmap formatJID . stanzaFrom)
 		, mattr "id" stanzaID
 		, mattr "xml:lang" stanzaLang
 		, if Data.Text.null typeStr then [] else [("type", typeStr)]


@@ 201,10 201,10 @@ stanzaToElement' stanza name typeStr = X.element name attrs payloads where
 
 elementToStanza :: Text -> X.Element -> Maybe ReceivedStanza
 elementToStanza ns elemt = do
-	let elemNS = X.nameNamespace . X.elementName $ elemt
+	let elemNS = X.nameNamespace (X.elementName elemt)
 	when (elemNS /= Just ns) Nothing
 	
-	let elemName = X.nameLocalName . X.elementName $ elemt
+	let elemName = X.nameLocalName (X.elementName elemt)
 	case elemName of
 		"message" -> ReceivedMessage `fmap` parseMessage elemt
 		"presence" -> ReceivedPresence `fmap` parsePresence elemt


@@ 226,11 226,11 @@ parseMessage elemt = do
 	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
+	return (Message msgType msgTo msgFrom msgID msgLang payloads)
 
 parsePresence :: X.Element -> Maybe Presence
 parsePresence elemt = do
-	let typeStr = maybe "" id $ X.attributeText "type" elemt
+	let typeStr = maybe "" id (X.attributeText "type" elemt)
 	pType <- case typeStr of
 		""             -> Just PresenceAvailable
 		"unavailable"  -> Just PresenceUnavailable


@@ 247,7 247,7 @@ parsePresence elemt = do
 	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
+	return (Presence pType msgTo msgFrom msgID msgLang payloads)
 
 parseIQ :: X.Element -> Maybe IQ
 parseIQ elemt = do


@@ 266,7 266,7 @@ parseIQ elemt = do
 	let payload = case X.elementChildren elemt of
 		[] -> Nothing
 		child:_ -> Just child
-	return $ IQ iqType msgTo msgFrom msgID msgLang payload
+	return (IQ iqType msgTo msgFrom msgID msgLang payload)
 
 xmlJID :: X.Name -> X.Element -> Maybe (Maybe JID)
 xmlJID name elemt = case X.attributeText name elemt of

@@ 74,14 74,14 @@ mkattr n val = (n, [ContentText val])
 serialiseElement :: Element -> Text
 serialiseElement e = text where
 	text = Data.Text.concat ["<", eName, " ", attrs, ">", contents, "</", eName, ">"]
-	eName = formatName $ elementName e
+	eName = formatName (elementName e)
 	formatName = escape . nameLocalName
-	attrs = Data.Text.intercalate " " $ map attr $ elementAttributes e ++ nsattr
-	attr (n, c) = Data.Text.concat $ [formatName n, "=\""] ++ map escapeContent c ++ ["\""]
+	attrs = Data.Text.intercalate " " (map attr (elementAttributes e ++ nsattr))
+	attr (n, c) = Data.Text.concat ([formatName n, "=\""] ++ map escapeContent c ++ ["\""])
 	nsattr = case nameNamespace $ elementName e of
 		Nothing -> []
 		Just ns -> [mkattr "xmlns" ns]
-	contents = Data.Text.concat $ map serialiseNode $ elementNodes e
+	contents = Data.Text.concat (map serialiseNode (elementNodes e))
 	
 	serialiseNode (NodeElement e') = serialiseElement e'
 	serialiseNode (NodeContent c) = escape (contentText c)


@@ 105,23 105,23 @@ newParser = do
 		return True
 	
 	SAX.setCallback p SAX.parsedBeginElement (\name attrs -> addEvent (EventBeginElement name attrs))
-	SAX.setCallback p SAX.parsedEndElement (\name -> addEvent (EventEndElement name))
-	SAX.setCallback p SAX.parsedCharacters (\txt -> addEvent (EventContent (ContentText txt)))
-	SAX.setCallback p SAX.parsedComment (\txt -> addEvent (EventComment txt))
-	SAX.setCallback p SAX.parsedInstruction (\i -> addEvent (EventInstruction i))
+	SAX.setCallback p SAX.parsedEndElement (addEvent . EventEndElement)
+	SAX.setCallback p SAX.parsedCharacters (addEvent . EventContent . ContentText)
+	SAX.setCallback p SAX.parsedComment (addEvent . EventComment)
+	SAX.setCallback p SAX.parsedInstruction (addEvent . EventInstruction)
 	SAX.setCallback p SAX.reportError (\err -> writeIORef ref (Left err) >> return False)
 	
-	return $ Parser p ref
+	return (Parser p ref)
 
 parse :: Parser -> ByteString -> Bool -> IO (Either Text [Event])
 parse (Parser p ref) bytes finish = do
 	writeIORef ref (Right [])
 	SAX.parseBytes p bytes
-	when finish $ SAX.parseComplete p
+	when finish (SAX.parseComplete p)
 	eitherEvents <- readIORef ref
 	return $ case eitherEvents of
 		Left err -> Left err
-		Right events -> Right $ reverse events
+		Right events -> Right (reverse events)
 
 readEvents :: Monad m
            => (Integer -> Event -> Bool)


@@ 183,4 183,4 @@ blockToNodes (begin:rest) = nodes where
 		(EventContent c, _) -> [NodeContent c]
 		_ -> []
 	
-	node n as = NodeElement $ Element n as $ eventsToNodes $ init rest
+	node n as = NodeElement (Element n as (eventsToNodes (init rest)))