M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +8 -9
@@ 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
M Network/Protocol/XMPP/Client/Authentication.hs => Network/Protocol/XMPP/Client/Authentication.hs +22 -21
@@ 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
M Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +4 -5
@@ 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
M Network/Protocol/XMPP/ErrorT.hs => Network/Protocol/XMPP/ErrorT.hs +5 -5
@@ 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))
M Network/Protocol/XMPP/Handle.hs => Network/Protocol/XMPP/Handle.hs +2 -2
@@ 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 ()
M Network/Protocol/XMPP/JID.hs => Network/Protocol/XMPP/JID.hs +5 -3
@@ 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)
M Network/Protocol/XMPP/Monad.hs => Network/Protocol/XMPP/Monad.hs +15 -15
@@ 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)
M Network/Protocol/XMPP/Stanza.hs => Network/Protocol/XMPP/Stanza.hs +9 -9
@@ 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
M Network/Protocol/XMPP/XML.hs => Network/Protocol/XMPP/XML.hs +12 -12
@@ 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)))