From f804d3610851f37b047c457769ef114513adce52 Mon Sep 17 00:00:00 2001 From: John Millikin Date: Thu, 7 Jul 2011 21:01:44 -0700 Subject: [PATCH] Reduce use of the ($) operator. --- Network/Protocol/XMPP/Client.hs | 17 ++++---- .../Protocol/XMPP/Client/Authentication.hs | 43 ++++++++++--------- Network/Protocol/XMPP/Component.hs | 9 ++-- Network/Protocol/XMPP/ErrorT.hs | 10 ++--- Network/Protocol/XMPP/Handle.hs | 4 +- Network/Protocol/XMPP/JID.hs | 8 ++-- Network/Protocol/XMPP/Monad.hs | 30 ++++++------- Network/Protocol/XMPP/Stanza.hs | 18 ++++---- Network/Protocol/XMPP/XML.hs | 24 +++++------ 9 files changed, 82 insertions(+), 81 deletions(-) diff --git a/Network/Protocol/XMPP/Client.hs b/Network/Protocol/XMPP/Client.hs index a59904c..080a4ab 100644 --- a/Network/Protocol/XMPP/Client.hs +++ b/Network/Protocol/XMPP/Client.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 diff --git a/Network/Protocol/XMPP/Client/Authentication.hs b/Network/Protocol/XMPP/Client/Authentication.hs index 43cbbf6..096b836 100644 --- a/Network/Protocol/XMPP/Client/Authentication.hs +++ b/Network/Protocol/XMPP/Client/Authentication.hs @@ -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 diff --git a/Network/Protocol/XMPP/Component.hs b/Network/Protocol/XMPP/Component.hs index 2c8ebd9..866cb93 100644 --- a/Network/Protocol/XMPP/Component.hs +++ b/Network/Protocol/XMPP/Component.hs @@ -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 diff --git a/Network/Protocol/XMPP/ErrorT.hs b/Network/Protocol/XMPP/ErrorT.hs index 71cd9de..b739a7e 100644 --- a/Network/Protocol/XMPP/ErrorT.hs +++ b/Network/Protocol/XMPP/ErrorT.hs @@ -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)) diff --git a/Network/Protocol/XMPP/Handle.hs b/Network/Protocol/XMPP/Handle.hs index ef4df61..c4e5020 100644 --- a/Network/Protocol/XMPP/Handle.hs +++ b/Network/Protocol/XMPP/Handle.hs @@ -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 () diff --git a/Network/Protocol/XMPP/JID.hs b/Network/Protocol/XMPP/JID.hs index 2c9cd11..91745e0 100644 --- a/Network/Protocol/XMPP/JID.hs +++ b/Network/Protocol/XMPP/JID.hs @@ -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) diff --git a/Network/Protocol/XMPP/Monad.hs b/Network/Protocol/XMPP/Monad.hs index 43c0017..416ede4 100644 --- a/Network/Protocol/XMPP/Monad.hs +++ b/Network/Protocol/XMPP/Monad.hs @@ -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) diff --git a/Network/Protocol/XMPP/Stanza.hs b/Network/Protocol/XMPP/Stanza.hs index c09efcb..dcdf499 100644 --- a/Network/Protocol/XMPP/Stanza.hs +++ b/Network/Protocol/XMPP/Stanza.hs @@ -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 diff --git a/Network/Protocol/XMPP/XML.hs b/Network/Protocol/XMPP/XML.hs index 17fb459..9f10c2e 100644 --- a/Network/Protocol/XMPP/XML.hs +++ b/Network/Protocol/XMPP/XML.hs @@ -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 = 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))) -- 2.38.5