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]