From 5f72869bc56530a24a1cbf0d38348d3a9f250c05 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 7 Feb 2018 12:35:53 +0100 Subject: [PATCH] Migrate from ErrorT to ExceptT --- source/Network/Xmpp/Concurrent.hs | 18 +++--- source/Network/Xmpp/Concurrent/IQ.hs | 2 +- source/Network/Xmpp/Concurrent/Threads.hs | 2 +- source/Network/Xmpp/Concurrent/Types.hs | 4 +- source/Network/Xmpp/Sasl.hs | 20 +++---- source/Network/Xmpp/Sasl/Common.hs | 22 +++---- .../Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs | 8 +-- source/Network/Xmpp/Sasl/Mechanisms/Plain.hs | 6 +- source/Network/Xmpp/Sasl/Mechanisms/Scram.hs | 8 +-- source/Network/Xmpp/Stream.hs | 58 +++++++++---------- source/Network/Xmpp/Tls.hs | 8 +-- source/Network/Xmpp/Types.hs | 10 +--- source/Network/Xmpp/Xep/InbandRegistration.hs | 20 +++---- source/Network/Xmpp/Xep/ServiceDiscovery.hs | 4 +- 14 files changed, 90 insertions(+), 100 deletions(-) diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 46385eb..3e5eb01 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -24,7 +24,7 @@ import Control.Concurrent (threadDelay) import Control.Concurrent.STM import qualified Control.Exception as Ex import Control.Monad -import Control.Monad.Error +import Control.Monad.Except import qualified Data.List as List import qualified Data.Map as Map import Data.Maybe @@ -168,7 +168,7 @@ newSession :: Stream -> HostName -> Maybe (ConnectionState -> [SaslHandler] , Maybe Text) -> IO (Either XmppFailure Session) -newSession stream config realm mbSasl = runErrorT $ do +newSession stream config realm mbSasl = runExceptT $ do write' <- liftIO $ withStream' (gets $ streamSend . streamHandle) stream writeSem <- liftIO $ newTMVarIO write' stanzaChan <- lift newTChanIO @@ -202,7 +202,7 @@ newSession stream config realm mbSasl = runErrorT $ do , rosterH , [ handleIQ iqHands sXmppElement] ] - (kill, sState, reader) <- ErrorT $ startThreadsWith writeSem stanzaHandler + (kill, sState, reader) <- ExceptT $ startThreadsWith writeSem stanzaHandler eh stream (keepAlive config) idGen <- liftIO $ sessionStanzaIDs config @@ -249,13 +249,13 @@ connectStream realm config mbSasl = do (\stream' -> case stream' of Left e -> return $ Left e Right stream -> do - res <- runErrorT $ do - ErrorT $ tls stream + res <- runExceptT $ do + ExceptT $ tls stream cs <- liftIO $ withStream (gets streamConnectionState) stream mbAuthError <- case mbSasl of Nothing -> return Nothing - Just (handlers, resource) -> ErrorT $ auth (handlers cs) + Just (handlers, resource) -> ExceptT $ auth (handlers cs) resource stream case mbAuthError of Nothing -> return () @@ -278,9 +278,9 @@ session :: HostName -- ^ The hostname / realm -> AuthData -> SessionConfiguration -- ^ configuration details -> IO (Either XmppFailure Session) -session realm mbSasl config = runErrorT $ do - stream <- ErrorT $ connectStream realm config mbSasl - ses <- ErrorT $ newSession stream config realm mbSasl +session realm mbSasl config = runExceptT $ do + stream <- ExceptT $ connectStream realm config mbSasl + ses <- ExceptT $ newSession stream config realm mbSasl liftIO $ when (enableRoster config) $ initRoster ses return ses diff --git a/source/Network/Xmpp/Concurrent/IQ.hs b/source/Network/Xmpp/Concurrent/IQ.hs index 658c26d..6e94b0e 100644 --- a/source/Network/Xmpp/Concurrent/IQ.hs +++ b/source/Network/Xmpp/Concurrent/IQ.hs @@ -9,7 +9,7 @@ import Control.Concurrent (forkIO) import Control.Concurrent.STM import Control.Concurrent.Thread.Delay (delay) import Control.Monad -import Control.Monad.Error +import Control.Monad.Except import Control.Monad.Trans import qualified Data.Map as Map import Data.Maybe diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs index 83c2220..763080f 100644 --- a/source/Network/Xmpp/Concurrent/Threads.hs +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -9,7 +9,7 @@ import Control.Concurrent import Control.Concurrent.STM import qualified Control.Exception.Lifted as Ex import Control.Monad -import Control.Monad.Error +import Control.Monad.Except import qualified Data.ByteString as BS import GHC.IO (unsafeUnmask) import Network.Xmpp.Concurrent.Types diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index 88c0b3d..cf504bf 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -7,7 +7,7 @@ module Network.Xmpp.Concurrent.Types where import Control.Concurrent import Control.Concurrent.STM import qualified Control.Exception.Lifted as Ex -import Control.Monad.Error +import Control.Monad.Except import qualified Data.ByteString as BS import Data.Default import qualified Data.Map as Map @@ -68,7 +68,7 @@ data Plugin' = Plugin' type Plugin = (XmppElement -> IO (Either XmppFailure ())) -- ^ pass stanza to -- next plugin - -> ErrorT XmppFailure IO Plugin' + -> ExceptT XmppFailure IO Plugin' type RosterPushCallback = Roster -> RosterUpdate -> IO () diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index 7e69903..60f9ffc 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -14,7 +14,7 @@ module Network.Xmpp.Sasl , auth ) where -import Control.Monad.Error +import Control.Monad.Except import Control.Monad.State.Strict import Data.Text (Text) import Data.XML.Pickle @@ -48,10 +48,10 @@ xmppSasl handlers stream = do Closed -> do lift $ errorM "Pontarius.Xmpp" "xmppSasl: Stream state closed." return . Left $ XmppNoStream - _ -> runErrorT $ do + _ -> runExceptT $ do -- TODO: Log details about handler? SaslHandler "show" instance? lift $ lift $ debugM "Pontarius.Xmpp" "xmppSasl: Performing handler..." - r <- ErrorT handler + r <- ExceptT handler case r of Just ae -> do lift $ lift $ errorM "Pontarius.Xmpp" $ @@ -60,7 +60,7 @@ xmppSasl handlers stream = do return $ Just ae Nothing -> do lift $ lift $ debugM "Pontarius.Xmpp" "xmppSasl: Authentication successful, restarting stream." - _ <- ErrorT restartStream + _ <- ExceptT restartStream lift $ lift $ debugM "Pontarius.Xmpp" "xmppSasl: Stream restarted." return Nothing @@ -70,12 +70,12 @@ auth :: [SaslHandler] -> Maybe Text -> Stream -> IO (Either XmppFailure (Maybe AuthFailure)) -auth mechanisms resource con = runErrorT $ do - mbAuthFail <- ErrorT $ xmppSasl mechanisms con +auth mechanisms resource con = runExceptT $ do + mbAuthFail <- ExceptT $ xmppSasl mechanisms con case mbAuthFail of Nothing -> do - _jid <- ErrorT $ xmppBind resource con - ErrorT $ flip withStream' con $ do + _jid <- ExceptT $ xmppBind resource con + ExceptT $ flip withStream' con $ do s <- get case sendStreamElement s of @@ -103,9 +103,9 @@ bindBody = pickleElem $ -- Sends a (synchronous) IQ set request for a (`Just') given or server-generated -- resource and extract the JID from the non-error response. xmppBind :: Maybe Text -> Stream -> IO (Either XmppFailure Jid) -xmppBind rsrc c = runErrorT $ do +xmppBind rsrc c = runExceptT $ do lift $ debugM "Pontarius.Xmpp" "Attempts to bind..." - answer <- ErrorT $ pushIQ "bind" Nothing Set Nothing (bindBody rsrc) c + answer <- ExceptT $ pushIQ "bind" Nothing Set Nothing (bindBody rsrc) c case answer of Right IQResult{iqResultPayload = Just b} -> do lift $ debugM "Pontarius.Xmpp" "xmppBind: IQ result received; unpickling JID..." diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index bc27044..defddf4 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -6,7 +6,7 @@ module Network.Xmpp.Sasl.Common where import Control.Applicative ((<$>)) -import Control.Monad.Error +import Control.Monad.Except import qualified Data.Attoparsec.ByteString.Char8 as AP import Data.Bits import qualified Data.ByteString as BS @@ -27,7 +27,7 @@ import qualified System.Random as Random import Control.Monad.State.Strict ---makeNonce :: ErrorT AuthFailure (StateT StreamState IO) BS.ByteString +--makeNonce :: ExceptT AuthFailure (StateT StreamState IO) BS.ByteString makeNonce :: IO BS.ByteString makeNonce = do g <- liftIO Random.newStdGen @@ -132,7 +132,7 @@ xpSaslElement = xpAlt saslSel quote :: BS.ByteString -> BS.ByteString quote x = BS.concat ["\"",x,"\""] -saslInit :: Text.Text -> Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) () +saslInit :: Text.Text -> Maybe BS.ByteString -> ExceptT AuthFailure (StateT StreamState IO) () saslInit mechanism payload = do r <- lift . pushElement . saslInitE mechanism $ Text.decodeUtf8 . encodeEmpty . B64.encode <$> payload @@ -145,7 +145,7 @@ saslInit mechanism payload = do encodeEmpty x = x -- | Pull the next element. -pullSaslElement :: ErrorT AuthFailure (StateT StreamState IO) SaslElement +pullSaslElement :: ExceptT AuthFailure (StateT StreamState IO) SaslElement pullSaslElement = do mbse <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement) case mbse of @@ -154,7 +154,7 @@ pullSaslElement = do Right (Right r) -> return r -- | Pull the next element, checking that it is a challenge. -pullChallenge :: ErrorT AuthFailure (StateT StreamState IO) (Maybe BS.ByteString) +pullChallenge :: ExceptT AuthFailure (StateT StreamState IO) (Maybe BS.ByteString) pullChallenge = do e <- pullSaslElement case e of @@ -165,12 +165,12 @@ pullChallenge = do _ -> throwError AuthOtherFailure -- TODO: Log -- | Extract value from Just, failing with AuthOtherFailure on Nothing. -saslFromJust :: Maybe a -> ErrorT AuthFailure (StateT StreamState IO) a +saslFromJust :: Maybe a -> ExceptT AuthFailure (StateT StreamState IO) a saslFromJust Nothing = throwError $ AuthOtherFailure -- TODO: Log saslFromJust (Just d) = return d -- | Pull the next element and check that it is success. -pullSuccess :: ErrorT AuthFailure (StateT StreamState IO) (Maybe Text.Text) +pullSuccess :: ExceptT AuthFailure (StateT StreamState IO) (Maybe Text.Text) pullSuccess = do e <- pullSaslElement case e of @@ -179,7 +179,7 @@ pullSuccess = do -- | Pull the next element. When it's success, return it's payload. -- If it's a challenge, send an empty response and pull success. -pullFinalMessage :: ErrorT AuthFailure (StateT StreamState IO) (Maybe BS.ByteString) +pullFinalMessage :: ExceptT AuthFailure (StateT StreamState IO) (Maybe BS.ByteString) pullFinalMessage = do challenge2 <- pullSaslElement case challenge2 of @@ -195,13 +195,13 @@ pullFinalMessage = do Right x -> return $ Just x -- | Extract p=q pairs from a challenge. -toPairs :: BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) Pairs +toPairs :: BS.ByteString -> ExceptT AuthFailure (StateT StreamState IO) Pairs toPairs ctext = case pairs ctext of Left _e -> throwError AuthOtherFailure -- TODO: Log Right r -> return r -- | Send a SASL response element. The content will be base64-encoded. -respond :: Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) () +respond :: Maybe BS.ByteString -> ExceptT AuthFailure (StateT StreamState IO) () respond m = do r <- lift . pushElement . saslResponseE . fmap (Text.decodeUtf8 . B64.encode) $ m case r of @@ -211,7 +211,7 @@ respond m = do -- | Run the appropriate stringprep profiles on the credentials. -- May fail with 'AuthStringPrepFailure' prepCredentials :: Text.Text -> Maybe Text.Text -> Text.Text - -> ErrorT AuthFailure (StateT StreamState IO) (Text.Text, Maybe Text.Text, Text.Text) + -> ExceptT AuthFailure (StateT StreamState IO) (Text.Text, Maybe Text.Text, Text.Text) prepCredentials authcid authzid password = case credentials of Nothing -> throwError $ AuthIllegalCredentials Just creds -> return creds diff --git a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs index 566c129..111ebb9 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs @@ -5,7 +5,7 @@ module Network.Xmpp.Sasl.Mechanisms.DigestMd5 ( digestMd5 ) where -import Control.Monad.Error +import Control.Monad.Except import Control.Monad.State.Strict import qualified Crypto.Classes as CC import qualified Data.Binary as Binary @@ -26,13 +26,13 @@ import Network.Xmpp.Types xmppDigestMd5 :: Text -- ^ Authentication identity (authzid or username) -> Maybe Text -- ^ Authorization identity (authcid) -> Text -- ^ Password (authzid) - -> ErrorT AuthFailure (StateT StreamState IO) () + -> ExceptT AuthFailure (StateT StreamState IO) () xmppDigestMd5 authcid' authzid' password' = do (ac, az, pw) <- prepCredentials authcid' authzid' password' Just address <- gets streamAddress xmppDigestMd5' address ac az pw where - xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> ErrorT AuthFailure (StateT StreamState IO) () + xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> ExceptT AuthFailure (StateT StreamState IO) () xmppDigestMd5' hostname authcid _authzid password = do -- TODO: use authzid? -- Push element and receive the challenge. _ <- saslInit "DIGEST-MD5" Nothing -- TODO: Check boolean? @@ -114,7 +114,7 @@ digestMd5 :: Username -- ^ Authentication identity (authcid or username) digestMd5 authcid authzid password = ( "DIGEST-MD5" , do - r <- runErrorT $ xmppDigestMd5 authcid authzid password + r <- runExceptT $ xmppDigestMd5 authcid authzid password case r of Left (AuthStreamFailure e) -> return $ Left e Left e -> return $ Right $ Just e diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs index 235f79d..1bbf00e 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs @@ -8,7 +8,7 @@ module Network.Xmpp.Sasl.Mechanisms.Plain ( plain ) where -import Control.Monad.Error +import Control.Monad.Except import Control.Monad.State.Strict import qualified Data.ByteString as BS import qualified Data.Text as Text @@ -21,7 +21,7 @@ import Network.Xmpp.Types xmppPlain :: Text.Text -- ^ Password -> Maybe Text.Text -- ^ Authorization identity (authzid) -> Text.Text -- ^ Authentication identity (authcid) - -> ErrorT AuthFailure (StateT StreamState IO) () + -> ExceptT AuthFailure (StateT StreamState IO) () xmppPlain authcid' authzid' password = do (ac, az, pw) <- prepCredentials authcid' authzid' password _ <- saslInit "PLAIN" ( Just $ plainMessage ac az pw) @@ -51,7 +51,7 @@ plain :: Username -- ^ authentication ID (username) plain authcid authzid passwd = ( "PLAIN" , do - r <- runErrorT $ xmppPlain authcid authzid passwd + r <- runExceptT $ xmppPlain authcid authzid passwd case r of Left (AuthStreamFailure e) -> return $ Left e Left e -> return $ Right $ Just e diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs index 37a87a2..08f3e6e 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs @@ -7,7 +7,7 @@ module Network.Xmpp.Sasl.Mechanisms.Scram where import Control.Applicative ((<$>)) -import Control.Monad.Error +import Control.Monad.Except import Control.Monad.State.Strict import qualified Crypto.Classes as Crypto import qualified Crypto.HMAC as Crypto @@ -37,7 +37,7 @@ scram :: (Crypto.Hash ctx hash) -> Text.Text -- ^ Authentication ID (user name) -> Maybe Text.Text -- ^ Authorization ID -> Text.Text -- ^ Password - -> ErrorT AuthFailure (StateT StreamState IO) () + -> ExceptT AuthFailure (StateT StreamState IO) () scram hToken authcid authzid password = do (ac, az, pw) <- prepCredentials authcid authzid password scramhelper ac az pw @@ -86,7 +86,7 @@ scram hToken authcid authzid password = do fromPairs :: Pairs -> BS.ByteString - -> ErrorT AuthFailure (StateT StreamState IO) (BS.ByteString, BS.ByteString, Integer) + -> ExceptT AuthFailure (StateT StreamState IO) (BS.ByteString, BS.ByteString, Integer) fromPairs prs cnonce | Just nonce <- lookup "r" prs , cnonce `BS.isPrefixOf` nonce , Just salt' <- lookup "s" prs @@ -154,7 +154,7 @@ scramSha1 :: Username -- ^ username scramSha1 authcid authzid passwd = ( "SCRAM-SHA-1" , do - r <- runErrorT $ scram (hashToken :: Crypto.SHA1) authcid authzid passwd + r <- runExceptT $ scram (hashToken :: Crypto.SHA1) authcid authzid passwd case r of Left (AuthStreamFailure e) -> return $ Left e Left e -> return $ Right $ Just e diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 334fab3..3535ce7 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -15,7 +15,7 @@ import Control.Concurrent.STM import qualified Control.Exception as Ex import qualified Control.Exception.Lifted as ExL import Control.Monad -import Control.Monad.Error +import Control.Monad.Except import Control.Monad.State.Strict import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -82,8 +82,8 @@ streamUnpickleElem p x = do Right r -> return r -- This is the conduit sink that handles the stream XML events. We extend it --- with ErrorT capabilities. -type StreamSink a = ConduitM Event Void (ErrorT XmppFailure IO) a +-- with ExceptT capabilities. +type StreamSink a = ConduitM Event Void (ExceptT XmppFailure IO) a -- Discards all events before the first EventBeginElement. throwOutJunk :: Monad m => ConduitM Event a m () @@ -110,7 +110,7 @@ openElementFromEvents = do -- generated, the connection to the server will be closed, and a XmppFailure -- will be produced. startStream :: StateT StreamState IO (Either XmppFailure ()) -startStream = runErrorT $ do +startStream = runExceptT $ do lift $ lift $ debugM "Pontarius.Xmpp" "Starting stream..." st <- lift $ get -- Set the `from' (which is also the expected to) attribute depending on the @@ -128,15 +128,15 @@ startStream = runErrorT $ do lift $ lift $ errorM "Pontarius.Xmpp" "Server sent no hostname." throwError XmppOtherFailure Just address -> do - ErrorT $ pushXmlDecl - ErrorT . pushOpenElement . streamNSHack $ + ExceptT $ pushXmlDecl + ExceptT . pushOpenElement . streamNSHack $ pickleElem xpStream ( "1.0" , expectedTo , Just (Jid Nothing (Nonempty address) Nothing) , Nothing , preferredLang $ streamConfiguration st ) - response <- ErrorT $ runEventsSink $ streamS expectedTo + response <- ExceptT $ runEventsSink $ streamS expectedTo case response of Right (ver, from, to, sid, lt, features) | versionFromText ver == Nothing -> closeStreamWithError @@ -181,14 +181,14 @@ startStream = runErrorT $ do | (isJust $ namePrefix name) && (fromJust (namePrefix name) /= "stream") -> closeStreamWithError StreamBadNamespacePrefix Nothing "Root name prefix set and not stream" - | otherwise -> ErrorT $ checkchildren (flattenAttrs attrs) + | otherwise -> ExceptT $ checkchildren (flattenAttrs attrs) where -- HACK: We include the default namespace to make isode's M-LINK server happy. streamNSHack e = e{elementAttributes = elementAttributes e ++ [( "xmlns" , [ContentText "jabber:client"])]} closeStreamWithError :: StreamErrorCondition -> Maybe Element -> String - -> ErrorT XmppFailure (StateT StreamState IO) () + -> ExceptT XmppFailure (StateT StreamState IO) () closeStreamWithError sec el msg = do void . lift . pushElement . pickleElem xpStreamError $ StreamErrorInfo sec Nothing el @@ -200,19 +200,19 @@ startStream = runErrorT $ do ver' = lookup "version" children xl = lookup xmlLang children in case () of () | Just Nothing == fmap jidFromText to' -> - runErrorT $ closeStreamWithError + runExceptT $ closeStreamWithError StreamBadNamespacePrefix Nothing "stream to not a valid JID" | Nothing == ver' -> - runErrorT $ closeStreamWithError + runExceptT $ closeStreamWithError StreamUnsupportedVersion Nothing "stream no version" | Just (Nothing :: Maybe LangTag) == (safeRead <$> xl) -> - runErrorT $ closeStreamWithError + runExceptT $ closeStreamWithError StreamInvalidXml Nothing "stream no language tag" | otherwise -> - runErrorT $ closeStreamWithError + runExceptT $ closeStreamWithError StreamBadFormat Nothing "" safeRead x = case reads $ Text.unpack x of @@ -281,8 +281,8 @@ logInput = go Nothing -- We buffer sources because we don't want to lose data when multiple -- xml-entities are sent with the same packet and we don't want to eternally -- block the StreamState while waiting for data to arrive -bufferSrc :: Source (ErrorT XmppFailure IO) o - -> IO (ConduitM i o (ErrorT XmppFailure IO) ()) +bufferSrc :: Source (ExceptT XmppFailure IO) o + -> IO (ConduitM i o (ExceptT XmppFailure IO) ()) bufferSrc src = do ref <- newTMVarIO $ DCI.sealConduitT src let go = do @@ -290,7 +290,7 @@ bufferSrc src = do (atomically $ takeTMVar ref) (\_ -> atomically . putTMVar ref $ zeroResumableSource) (\s -> do - res <- runErrorT (s $$++ await) + res <- runExceptT (s $$++ await) case res of Left e -> do atomically $ putTMVar ref zeroResumableSource @@ -349,10 +349,10 @@ streamS _expectedTo = do -- TODO: check expectedTo -- | Connects to the XMPP server and opens the XMPP stream against the given -- realm. openStream :: HostName -> StreamConfiguration -> IO (Either XmppFailure (Stream)) -openStream realm config = runErrorT $ do +openStream realm config = runExceptT $ do lift $ debugM "Pontarius.Xmpp" "Opening stream..." stream' <- createStream realm config - ErrorT . liftIO $ withStream startStream stream' + ExceptT . liftIO $ withStream startStream stream' return stream' -- | Send \"\" and wait for the server to finish processing and @@ -455,11 +455,11 @@ pushOpenElement e = do -- `Connect-and-resumes' the given sink to the stream source, and pulls a -- `b' value. -runEventsSink :: Sink Event (ErrorT XmppFailure IO) b +runEventsSink :: Sink Event (ExceptT XmppFailure IO) b -> StateT StreamState IO (Either XmppFailure b) runEventsSink snk = do -- TODO: Wrap exceptions? src <- gets streamEventSource - lift . runErrorT $ src $$ snk + lift . runExceptT $ src $$ snk pullElement :: StateT StreamState IO (Either XmppFailure Element) pullElement = do @@ -543,7 +543,7 @@ xmppNoStream = StreamState { , streamConfiguration = def } -zeroSource :: Source (ErrorT XmppFailure IO) a +zeroSource :: Source (ExceptT XmppFailure IO) a zeroSource = do liftIO $ debugM "Pontarius.Xmpp" "zeroSource" throwError XmppNoStream @@ -559,11 +559,11 @@ handleToStreamHandle h = StreamHandle { streamSend = \d -> , streamClose = hClose h } -createStream :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (Stream) +createStream :: HostName -> StreamConfiguration -> ExceptT XmppFailure IO (Stream) createStream realm config = do result <- connect realm config case result of - Just hand -> ErrorT $ do + Just hand -> ExceptT $ do debugM "Pontarius.Xmpp" "Acquired handle." debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle." eSource <- liftIO . bufferSrc $ @@ -598,7 +598,7 @@ createStream realm config = do maybeSetTlsHost host = over tlsIdentL (updateHost host) -- Connects using the specified method. Returns the Handle acquired, if any. -connect :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO +connect :: HostName -> StreamConfiguration -> ExceptT XmppFailure IO (Maybe StreamHandle) connect realm config = do case connectionDetails config of @@ -626,7 +626,7 @@ connect realm config = do return . Just $ handleToStreamHandle h' UseConnection mkC -> Just <$> mkC -connectSrv :: ResolvConf -> String -> ErrorT XmppFailure IO (Maybe Handle) +connectSrv :: ResolvConf -> String -> ExceptT XmppFailure IO (Maybe Handle) connectSrv config host = do case checkHostName (Text.pack host) of Just host' -> do @@ -735,8 +735,8 @@ rethrowErrorCall action = do -- Provides a list of A(AAA) names and port numbers upon a successful -- DNS-SRV request, or `Nothing' if the DNS-SRV request failed. -srvLookup :: Text -> ResolvSeed -> ErrorT XmppFailure IO (Maybe [(Domain, Word16)]) -srvLookup realm resolvSeed = ErrorT $ do +srvLookup :: Text -> ResolvSeed -> ExceptT XmppFailure IO (Maybe [(Domain, Word16)]) +srvLookup realm resolvSeed = ExceptT $ do result <- Ex.try $ rethrowErrorCall $ withResolver resolvSeed $ \resolver -> do srvResult <- lookupSRV resolver $ BSC8.pack $ "_xmpp-client._tcp." ++ (Text.unpack realm) ++ "." @@ -818,8 +818,8 @@ pushIQ :: Text -> Element -> Stream -> IO (Either XmppFailure (Either IQError IQResult)) -pushIQ iqID to tp lang body stream = runErrorT $ do - ErrorT $ pushStanza +pushIQ iqID to tp lang body stream = runExceptT $ do + ExceptT $ pushStanza (IQRequestS $ IQRequest iqID Nothing to lang tp body []) stream res <- lift $ pullStanza stream case res of diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs index 1fbc18a..c0654b6 100644 --- a/source/Network/Xmpp/Tls.hs +++ b/source/Network/Xmpp/Tls.hs @@ -9,7 +9,7 @@ module Network.Xmpp.Tls where import Control.Applicative ((<$>)) import qualified Control.Exception.Lifted as Ex import Control.Monad -import Control.Monad.Error +import Control.Monad.Except import Control.Monad.State.Strict import "crypto-random" Crypto.Random import qualified Data.ByteString as BS @@ -56,7 +56,7 @@ tls con = fmap join -- We can have Left values both from exceptions and the -- error monad. Join unifies them into one error layer . wrapExceptions . flip withStream con - . runErrorT $ do + . runExceptT $ do conf <- gets streamConfiguration sState <- gets streamConnectionState case sState of @@ -85,7 +85,7 @@ tls con = fmap join -- We can have Left values both from exceptions and the startTls = do liftIO $ infoM "Pontarius.Xmpp.Tls" "Running StartTLS" params <- gets $ tlsParams . streamConfiguration - ErrorT $ pushElement starttlsE + ExceptT $ pushElement starttlsE answer <- lift $ pullElement case answer of Left e -> throwError e @@ -173,7 +173,7 @@ connectTls :: ResolvConf -- ^ Resolv conf to use (try 'defaultResolvConf' as a -> ClientParams -- ^ TLS parameters to use when securing the connection -> String -- ^ Host to use when connecting (will be resolved -- using SRV records) - -> ErrorT XmppFailure IO StreamHandle + -> ExceptT XmppFailure IO StreamHandle connectTls config params host = do h <- connectSrv config host >>= \h' -> case h' of Nothing -> throwError TcpConnectionFailure diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index fb153a2..4ead383 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -89,7 +89,7 @@ module Network.Xmpp.Types import Control.Applicative ((<$>), (<|>), many) import Control.Concurrent.STM import Control.Exception -import Control.Monad.Error +import Control.Monad.Except import qualified Data.Attoparsec.Text as AP import qualified Data.ByteString as BS import Data.Char (isSpace) @@ -623,7 +623,6 @@ data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream deriving (Show, Eq, Typeable) instance Exception XmppFailure -instance Error XmppFailure where noMsg = XmppOtherFailure -- | Signals a SASL authentication error condition. data AuthFailure = -- | No mechanism offered by the server was matched @@ -641,9 +640,6 @@ data AuthFailure = -- | No mechanism offered by the server was matched | AuthOtherFailure deriving (Eq, Show) -instance Error AuthFailure where - noMsg = AuthOtherFailure - -- ============================================================================= -- XML TYPES -- ============================================================================= @@ -791,7 +787,7 @@ data StreamState = StreamState -- | Functions to send, receive, flush, and close the stream , streamHandle :: StreamHandle -- | Event conduit source, and its associated finalizer - , streamEventSource :: Source (ErrorT XmppFailure IO) Event + , streamEventSource :: Source (ExceptT XmppFailure IO) Event -- | Stream features advertised by the server , streamFeatures :: !StreamFeatures -- TODO: Maybe? -- | The hostname or IP specified for the connection @@ -1229,7 +1225,7 @@ data ConnectionDetails = UseRealm -- ^ Use realm to resolv host. This is the -- default. | UseSrv HostName -- ^ Use this hostname for a SRV lookup | UseHost HostName PortNumber -- ^ Use specified host - | UseConnection (ErrorT XmppFailure IO StreamHandle) + | UseConnection (ExceptT XmppFailure IO StreamHandle) -- ^ Use a custom method to create a StreamHandle. This -- will also be used by reconnect. For example, to -- establish TLS before starting the stream as done by diff --git a/source/Network/Xmpp/Xep/InbandRegistration.hs b/source/Network/Xmpp/Xep/InbandRegistration.hs index 6430509..cb20897 100644 --- a/source/Network/Xmpp/Xep/InbandRegistration.hs +++ b/source/Network/Xmpp/Xep/InbandRegistration.hs @@ -11,7 +11,7 @@ module Network.Xmpp.Xep.InbandRegistration where import Control.Applicative((<$>)) import Control.Arrow(left) import Control.Exception -import Control.Monad.Error +import Control.Monad.Except import Control.Monad.State import Data.Either (partitionEithers) @@ -35,8 +35,6 @@ data IbrError = IbrNotSupported | IbrTimeout deriving (Show) -instance Error IbrError - data Query = Query { instructions :: Maybe Text.Text , registered :: Bool @@ -82,8 +80,6 @@ data RegisterError = IbrError IbrError | AlreadyRegistered deriving (Show) -instance Error RegisterError - mapError f = mapErrorT (liftM $ left f) -- | Retrieve the necessary fields and fill them in to register an account with @@ -91,8 +87,8 @@ mapError f = mapErrorT (liftM $ left f) registerWith :: [(Field, Text.Text)] -> Stream -> IO (Either RegisterError Query) -registerWith givenFields con = runErrorT $ do - fs <- mapError IbrError . ErrorT $ requestFields con +registerWith givenFields con = runExceptT $ do + fs <- mapError IbrError . ExceptT $ requestFields con when (registered fs) . throwError $ AlreadyRegistered let res = flip map (fields fs) $ \(field,_) -> case lookup field givenFields of @@ -101,18 +97,18 @@ registerWith givenFields con = runErrorT $ do fields <- case partitionEithers res of ([],fs) -> return fs (fs,_) -> throwError $ MissingFields fs - result <- mapError IbrError . ErrorT $ query Set (emptyQuery {fields}) con + result <- mapError IbrError . ExceptT $ query Set (emptyQuery {fields}) con return result -createAccountWith host hostname port fields = runErrorT $ do +createAccountWith host hostname port fields = runExceptT $ do con' <- liftIO $ connectTcp host port hostname con <- case con' of Left e -> throwError $ IbrError IbrNoConnection Right r -> return r lift $ startTLS exampleParams con - ErrorT $ registerWith fields con + ExceptT $ registerWith fields con deleteAccount host hostname port username password = do con <- simpleConnect host port hostname username password Nothing @@ -127,8 +123,8 @@ unregister = query Set $ emptyQuery {remove = True} unregister' :: Session -> IO (Either IbrError Query) unregister' = query' Set $ emptyQuery {remove = True} -requestFields con = runErrorT $ do - qr <- ErrorT $ query Get emptyQuery con +requestFields con = runExceptT $ do + qr <- ExceptT $ query Get emptyQuery con return $ qr xpQuery :: PU [XML.Node] Query diff --git a/source/Network/Xmpp/Xep/ServiceDiscovery.hs b/source/Network/Xmpp/Xep/ServiceDiscovery.hs index a392684..020606f 100644 --- a/source/Network/Xmpp/Xep/ServiceDiscovery.hs +++ b/source/Network/Xmpp/Xep/ServiceDiscovery.hs @@ -17,7 +17,7 @@ module Network.Xmpp.Xep.ServiceDiscovery where import Control.Applicative ((<$>)) -import Control.Monad.Error +import Control.Monad.Except import qualified Data.Map as Map import qualified Data.Text as Text import Data.XML.Pickle @@ -36,8 +36,6 @@ data DiscoError = DiscoNoQueryElement deriving (Show) -instance Error DiscoError - -- Identity ---------------------