asakul
/
pontarius-xmpp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

Migrate from ErrorT to ExceptT

master
Philipp Balzarek 8 years ago
parent
2731474821
commit
5f72869bc5
14 changed files with 90 additions and 100 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 18
      source/Network/Xmpp/Concurrent.hs
  2. 2
      source/Network/Xmpp/Concurrent/IQ.hs
  3. 2
      source/Network/Xmpp/Concurrent/Threads.hs
  4. 4
      source/Network/Xmpp/Concurrent/Types.hs
  5. 20
      source/Network/Xmpp/Sasl.hs
  6. 22
      source/Network/Xmpp/Sasl/Common.hs
  7. 8
      source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs
  8. 6
      source/Network/Xmpp/Sasl/Mechanisms/Plain.hs
  9. 8
      source/Network/Xmpp/Sasl/Mechanisms/Scram.hs
  10. 58
      source/Network/Xmpp/Stream.hs
  11. 8
      source/Network/Xmpp/Tls.hs
  12. 10
      source/Network/Xmpp/Types.hs
  13. 20
      source/Network/Xmpp/Xep/InbandRegistration.hs
  14. 4
      source/Network/Xmpp/Xep/ServiceDiscovery.hs

18
source/Network/Xmpp/Concurrent.hs
Unescape View File

@ -24,7 +24,7 @@ import Control.Concurrent (threadDelay)
import Control.Concurrent.STM import Control.Concurrent.STM
import qualified Control.Exception as Ex import qualified Control.Exception as Ex
import Control.Monad import Control.Monad
import Control.Monad.Error import Control.Monad.Except
import qualified Data.List as List import qualified Data.List as List
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe import Data.Maybe
@ -168,7 +168,7 @@ newSession :: Stream
-> HostName -> HostName
-> Maybe (ConnectionState -> [SaslHandler] , Maybe Text) -> Maybe (ConnectionState -> [SaslHandler] , Maybe Text)
-> IO (Either XmppFailure Session) -> 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 write' <- liftIO $ withStream' (gets $ streamSend . streamHandle) stream
writeSem <- liftIO $ newTMVarIO write' writeSem <- liftIO $ newTMVarIO write'
stanzaChan <- lift newTChanIO stanzaChan <- lift newTChanIO
@ -202,7 +202,7 @@ newSession stream config realm mbSasl = runErrorT $ do
, rosterH , rosterH
, [ handleIQ iqHands sXmppElement] , [ handleIQ iqHands sXmppElement]
] ]
(kill, sState, reader) <- ErrorT $ startThreadsWith writeSem stanzaHandler (kill, sState, reader) <- ExceptT $ startThreadsWith writeSem stanzaHandler
eh stream eh stream
(keepAlive config) (keepAlive config)
idGen <- liftIO $ sessionStanzaIDs config idGen <- liftIO $ sessionStanzaIDs config
@ -249,13 +249,13 @@ connectStream realm config mbSasl = do
(\stream' -> case stream' of (\stream' -> case stream' of
Left e -> return $ Left e Left e -> return $ Left e
Right stream -> do Right stream -> do
res <- runErrorT $ do res <- runExceptT $ do
ErrorT $ tls stream ExceptT $ tls stream
cs <- liftIO $ withStream (gets streamConnectionState) cs <- liftIO $ withStream (gets streamConnectionState)
stream stream
mbAuthError <- case mbSasl of mbAuthError <- case mbSasl of
Nothing -> return Nothing Nothing -> return Nothing
Just (handlers, resource) -> ErrorT $ auth (handlers cs) Just (handlers, resource) -> ExceptT $ auth (handlers cs)
resource stream resource stream
case mbAuthError of case mbAuthError of
Nothing -> return () Nothing -> return ()
@ -278,9 +278,9 @@ session :: HostName -- ^ The hostname / realm
-> AuthData -> AuthData
-> SessionConfiguration -- ^ configuration details -> SessionConfiguration -- ^ configuration details
-> IO (Either XmppFailure Session) -> IO (Either XmppFailure Session)
session realm mbSasl config = runErrorT $ do session realm mbSasl config = runExceptT $ do
stream <- ErrorT $ connectStream realm config mbSasl stream <- ExceptT $ connectStream realm config mbSasl
ses <- ErrorT $ newSession stream config realm mbSasl ses <- ExceptT $ newSession stream config realm mbSasl
liftIO $ when (enableRoster config) $ initRoster ses liftIO $ when (enableRoster config) $ initRoster ses
return ses return ses

2
source/Network/Xmpp/Concurrent/IQ.hs
Unescape View File

@ -9,7 +9,7 @@ import Control.Concurrent (forkIO)
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.Thread.Delay (delay) import Control.Concurrent.Thread.Delay (delay)
import Control.Monad import Control.Monad
import Control.Monad.Error import Control.Monad.Except
import Control.Monad.Trans import Control.Monad.Trans
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe import Data.Maybe

2
source/Network/Xmpp/Concurrent/Threads.hs
Unescape View File

@ -9,7 +9,7 @@ import Control.Concurrent
import Control.Concurrent.STM import Control.Concurrent.STM
import qualified Control.Exception.Lifted as Ex import qualified Control.Exception.Lifted as Ex
import Control.Monad import Control.Monad
import Control.Monad.Error import Control.Monad.Except
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import GHC.IO (unsafeUnmask) import GHC.IO (unsafeUnmask)
import Network.Xmpp.Concurrent.Types import Network.Xmpp.Concurrent.Types

4
source/Network/Xmpp/Concurrent/Types.hs
Unescape View File

@ -7,7 +7,7 @@ module Network.Xmpp.Concurrent.Types where
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.STM import Control.Concurrent.STM
import qualified Control.Exception.Lifted as Ex import qualified Control.Exception.Lifted as Ex
import Control.Monad.Error import Control.Monad.Except
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.Default import Data.Default
import qualified Data.Map as Map import qualified Data.Map as Map
@ -68,7 +68,7 @@ data Plugin' = Plugin'
type Plugin = (XmppElement -> IO (Either XmppFailure ())) -- ^ pass stanza to type Plugin = (XmppElement -> IO (Either XmppFailure ())) -- ^ pass stanza to
-- next plugin -- next plugin
-> ErrorT XmppFailure IO Plugin' -> ExceptT XmppFailure IO Plugin'
type RosterPushCallback = Roster -> RosterUpdate -> IO () type RosterPushCallback = Roster -> RosterUpdate -> IO ()

20
source/Network/Xmpp/Sasl.hs
Unescape View File

@ -14,7 +14,7 @@ module Network.Xmpp.Sasl
, auth , auth
) where ) where
import Control.Monad.Error import Control.Monad.Except
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Data.Text (Text) import Data.Text (Text)
import Data.XML.Pickle import Data.XML.Pickle
@ -48,10 +48,10 @@ xmppSasl handlers stream = do
Closed -> do Closed -> do
lift $ errorM "Pontarius.Xmpp" "xmppSasl: Stream state closed." lift $ errorM "Pontarius.Xmpp" "xmppSasl: Stream state closed."
return . Left $ XmppNoStream return . Left $ XmppNoStream
_ -> runErrorT $ do _ -> runExceptT $ do
-- TODO: Log details about handler? SaslHandler "show" instance? -- TODO: Log details about handler? SaslHandler "show" instance?
lift $ lift $ debugM "Pontarius.Xmpp" "xmppSasl: Performing handler..." lift $ lift $ debugM "Pontarius.Xmpp" "xmppSasl: Performing handler..."
r <- ErrorT handler r <- ExceptT handler
case r of case r of
Just ae -> do Just ae -> do
lift $ lift $ errorM "Pontarius.Xmpp" $ lift $ lift $ errorM "Pontarius.Xmpp" $
@ -60,7 +60,7 @@ xmppSasl handlers stream = do
return $ Just ae return $ Just ae
Nothing -> do Nothing -> do
lift $ lift $ debugM "Pontarius.Xmpp" "xmppSasl: Authentication successful, restarting stream." lift $ lift $ debugM "Pontarius.Xmpp" "xmppSasl: Authentication successful, restarting stream."
_ <- ErrorT restartStream _ <- ExceptT restartStream
lift $ lift $ debugM "Pontarius.Xmpp" "xmppSasl: Stream restarted." lift $ lift $ debugM "Pontarius.Xmpp" "xmppSasl: Stream restarted."
return Nothing return Nothing
@ -70,12 +70,12 @@ auth :: [SaslHandler]
-> Maybe Text -> Maybe Text
-> Stream -> Stream
-> IO (Either XmppFailure (Maybe AuthFailure)) -> IO (Either XmppFailure (Maybe AuthFailure))
auth mechanisms resource con = runErrorT $ do auth mechanisms resource con = runExceptT $ do
mbAuthFail <- ErrorT $ xmppSasl mechanisms con mbAuthFail <- ExceptT $ xmppSasl mechanisms con
case mbAuthFail of case mbAuthFail of
Nothing -> do Nothing -> do
_jid <- ErrorT $ xmppBind resource con _jid <- ExceptT $ xmppBind resource con
ErrorT $ flip withStream' con $ do ExceptT $ flip withStream' con $ do
s <- get s <- get
case sendStreamElement s of case sendStreamElement s of
@ -103,9 +103,9 @@ bindBody = pickleElem $
-- Sends a (synchronous) IQ set request for a (`Just') given or server-generated -- Sends a (synchronous) IQ set request for a (`Just') given or server-generated
-- resource and extract the JID from the non-error response. -- resource and extract the JID from the non-error response.
xmppBind :: Maybe Text -> Stream -> IO (Either XmppFailure Jid) 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..." 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 case answer of
Right IQResult{iqResultPayload = Just b} -> do Right IQResult{iqResultPayload = Just b} -> do
lift $ debugM "Pontarius.Xmpp" "xmppBind: IQ result received; unpickling JID..." lift $ debugM "Pontarius.Xmpp" "xmppBind: IQ result received; unpickling JID..."

22
source/Network/Xmpp/Sasl/Common.hs
Unescape View File

@ -6,7 +6,7 @@
module Network.Xmpp.Sasl.Common where module Network.Xmpp.Sasl.Common where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Monad.Error import Control.Monad.Except
import qualified Data.Attoparsec.ByteString.Char8 as AP import qualified Data.Attoparsec.ByteString.Char8 as AP
import Data.Bits import Data.Bits
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
@ -27,7 +27,7 @@ import qualified System.Random as Random
import Control.Monad.State.Strict 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 :: IO BS.ByteString
makeNonce = do makeNonce = do
g <- liftIO Random.newStdGen g <- liftIO Random.newStdGen
@ -132,7 +132,7 @@ xpSaslElement = xpAlt saslSel
quote :: BS.ByteString -> BS.ByteString quote :: BS.ByteString -> BS.ByteString
quote x = BS.concat ["\"",x,"\""] 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 saslInit mechanism payload = do
r <- lift . pushElement . saslInitE mechanism $ r <- lift . pushElement . saslInitE mechanism $
Text.decodeUtf8 . encodeEmpty . B64.encode <$> payload Text.decodeUtf8 . encodeEmpty . B64.encode <$> payload
@ -145,7 +145,7 @@ saslInit mechanism payload = do
encodeEmpty x = x encodeEmpty x = x
-- | Pull the next element. -- | Pull the next element.
pullSaslElement :: ErrorT AuthFailure (StateT StreamState IO) SaslElement pullSaslElement :: ExceptT AuthFailure (StateT StreamState IO) SaslElement
pullSaslElement = do pullSaslElement = do
mbse <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement) mbse <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement)
case mbse of case mbse of
@ -154,7 +154,7 @@ pullSaslElement = do
Right (Right r) -> return r Right (Right r) -> return r
-- | Pull the next element, checking that it is a challenge. -- | 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 pullChallenge = do
e <- pullSaslElement e <- pullSaslElement
case e of case e of
@ -165,12 +165,12 @@ pullChallenge = do
_ -> throwError AuthOtherFailure -- TODO: Log _ -> throwError AuthOtherFailure -- TODO: Log
-- | Extract value from Just, failing with AuthOtherFailure on Nothing. -- | 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 Nothing = throwError $ AuthOtherFailure -- TODO: Log
saslFromJust (Just d) = return d saslFromJust (Just d) = return d
-- | Pull the next element and check that it is success. -- | 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 pullSuccess = do
e <- pullSaslElement e <- pullSaslElement
case e of case e of
@ -179,7 +179,7 @@ pullSuccess = do
-- | Pull the next element. When it's success, return it's payload. -- | Pull the next element. When it's success, return it's payload.
-- If it's a challenge, send an empty response and pull success. -- 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 pullFinalMessage = do
challenge2 <- pullSaslElement challenge2 <- pullSaslElement
case challenge2 of case challenge2 of
@ -195,13 +195,13 @@ pullFinalMessage = do
Right x -> return $ Just x Right x -> return $ Just x
-- | Extract p=q pairs from a challenge. -- | 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 toPairs ctext = case pairs ctext of
Left _e -> throwError AuthOtherFailure -- TODO: Log Left _e -> throwError AuthOtherFailure -- TODO: Log
Right r -> return r Right r -> return r
-- | Send a SASL response element. The content will be base64-encoded. -- | 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 respond m = do
r <- lift . pushElement . saslResponseE . fmap (Text.decodeUtf8 . B64.encode) $ m r <- lift . pushElement . saslResponseE . fmap (Text.decodeUtf8 . B64.encode) $ m
case r of case r of
@ -211,7 +211,7 @@ respond m = do
-- | Run the appropriate stringprep profiles on the credentials. -- | Run the appropriate stringprep profiles on the credentials.
-- May fail with 'AuthStringPrepFailure' -- May fail with 'AuthStringPrepFailure'
prepCredentials :: Text.Text -> Maybe Text.Text -> Text.Text 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 prepCredentials authcid authzid password = case credentials of
Nothing -> throwError $ AuthIllegalCredentials Nothing -> throwError $ AuthIllegalCredentials
Just creds -> return creds Just creds -> return creds

8
source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs
Unescape View File

@ -5,7 +5,7 @@ module Network.Xmpp.Sasl.Mechanisms.DigestMd5
( digestMd5 ( digestMd5
) where ) where
import Control.Monad.Error import Control.Monad.Except
import Control.Monad.State.Strict import Control.Monad.State.Strict
import qualified Crypto.Classes as CC import qualified Crypto.Classes as CC
import qualified Data.Binary as Binary import qualified Data.Binary as Binary
@ -26,13 +26,13 @@ import Network.Xmpp.Types
xmppDigestMd5 :: Text -- ^ Authentication identity (authzid or username) xmppDigestMd5 :: Text -- ^ Authentication identity (authzid or username)
-> Maybe Text -- ^ Authorization identity (authcid) -> Maybe Text -- ^ Authorization identity (authcid)
-> Text -- ^ Password (authzid) -> Text -- ^ Password (authzid)
-> ErrorT AuthFailure (StateT StreamState IO) () -> ExceptT AuthFailure (StateT StreamState IO) ()
xmppDigestMd5 authcid' authzid' password' = do xmppDigestMd5 authcid' authzid' password' = do
(ac, az, pw) <- prepCredentials authcid' authzid' password' (ac, az, pw) <- prepCredentials authcid' authzid' password'
Just address <- gets streamAddress Just address <- gets streamAddress
xmppDigestMd5' address ac az pw xmppDigestMd5' address ac az pw
where 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? xmppDigestMd5' hostname authcid _authzid password = do -- TODO: use authzid?
-- Push element and receive the challenge. -- Push element and receive the challenge.
_ <- saslInit "DIGEST-MD5" Nothing -- TODO: Check boolean? _ <- saslInit "DIGEST-MD5" Nothing -- TODO: Check boolean?
@ -114,7 +114,7 @@ digestMd5 :: Username -- ^ Authentication identity (authcid or username)
digestMd5 authcid authzid password = digestMd5 authcid authzid password =
( "DIGEST-MD5" ( "DIGEST-MD5"
, do , do
r <- runErrorT $ xmppDigestMd5 authcid authzid password r <- runExceptT $ xmppDigestMd5 authcid authzid password
case r of case r of
Left (AuthStreamFailure e) -> return $ Left e Left (AuthStreamFailure e) -> return $ Left e
Left e -> return $ Right $ Just e Left e -> return $ Right $ Just e

6
source/Network/Xmpp/Sasl/Mechanisms/Plain.hs
Unescape View File

@ -8,7 +8,7 @@ module Network.Xmpp.Sasl.Mechanisms.Plain
( plain ( plain
) where ) where
import Control.Monad.Error import Control.Monad.Except
import Control.Monad.State.Strict import Control.Monad.State.Strict
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.Text as Text import qualified Data.Text as Text
@ -21,7 +21,7 @@ import Network.Xmpp.Types
xmppPlain :: Text.Text -- ^ Password xmppPlain :: Text.Text -- ^ Password
-> Maybe Text.Text -- ^ Authorization identity (authzid) -> Maybe Text.Text -- ^ Authorization identity (authzid)
-> Text.Text -- ^ Authentication identity (authcid) -> Text.Text -- ^ Authentication identity (authcid)
-> ErrorT AuthFailure (StateT StreamState IO) () -> ExceptT AuthFailure (StateT StreamState IO) ()
xmppPlain authcid' authzid' password = do xmppPlain authcid' authzid' password = do
(ac, az, pw) <- prepCredentials authcid' authzid' password (ac, az, pw) <- prepCredentials authcid' authzid' password
_ <- saslInit "PLAIN" ( Just $ plainMessage ac az pw) _ <- saslInit "PLAIN" ( Just $ plainMessage ac az pw)
@ -51,7 +51,7 @@ plain :: Username -- ^ authentication ID (username)
plain authcid authzid passwd = plain authcid authzid passwd =
( "PLAIN" ( "PLAIN"
, do , do
r <- runErrorT $ xmppPlain authcid authzid passwd r <- runExceptT $ xmppPlain authcid authzid passwd
case r of case r of
Left (AuthStreamFailure e) -> return $ Left e Left (AuthStreamFailure e) -> return $ Left e
Left e -> return $ Right $ Just e Left e -> return $ Right $ Just e

8
source/Network/Xmpp/Sasl/Mechanisms/Scram.hs
Unescape View File

@ -7,7 +7,7 @@ module Network.Xmpp.Sasl.Mechanisms.Scram
where where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Monad.Error import Control.Monad.Except
import Control.Monad.State.Strict import Control.Monad.State.Strict
import qualified Crypto.Classes as Crypto import qualified Crypto.Classes as Crypto
import qualified Crypto.HMAC as Crypto import qualified Crypto.HMAC as Crypto
@ -37,7 +37,7 @@ scram :: (Crypto.Hash ctx hash)
-> Text.Text -- ^ Authentication ID (user name) -> Text.Text -- ^ Authentication ID (user name)
-> Maybe Text.Text -- ^ Authorization ID -> Maybe Text.Text -- ^ Authorization ID
-> Text.Text -- ^ Password -> Text.Text -- ^ Password
-> ErrorT AuthFailure (StateT StreamState IO) () -> ExceptT AuthFailure (StateT StreamState IO) ()
scram hToken authcid authzid password = do scram hToken authcid authzid password = do
(ac, az, pw) <- prepCredentials authcid authzid password (ac, az, pw) <- prepCredentials authcid authzid password
scramhelper ac az pw scramhelper ac az pw
@ -86,7 +86,7 @@ scram hToken authcid authzid password = do
fromPairs :: Pairs fromPairs :: Pairs
-> BS.ByteString -> 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 fromPairs prs cnonce | Just nonce <- lookup "r" prs
, cnonce `BS.isPrefixOf` nonce , cnonce `BS.isPrefixOf` nonce
, Just salt' <- lookup "s" prs , Just salt' <- lookup "s" prs
@ -154,7 +154,7 @@ scramSha1 :: Username -- ^ username
scramSha1 authcid authzid passwd = scramSha1 authcid authzid passwd =
( "SCRAM-SHA-1" ( "SCRAM-SHA-1"
, do , do
r <- runErrorT $ scram (hashToken :: Crypto.SHA1) authcid authzid passwd r <- runExceptT $ scram (hashToken :: Crypto.SHA1) authcid authzid passwd
case r of case r of
Left (AuthStreamFailure e) -> return $ Left e Left (AuthStreamFailure e) -> return $ Left e
Left e -> return $ Right $ Just e Left e -> return $ Right $ Just e

58
source/Network/Xmpp/Stream.hs
Unescape View File

@ -15,7 +15,7 @@ import Control.Concurrent.STM
import qualified Control.Exception as Ex import qualified Control.Exception as Ex
import qualified Control.Exception.Lifted as ExL import qualified Control.Exception.Lifted as ExL
import Control.Monad import Control.Monad
import Control.Monad.Error import Control.Monad.Except
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
@ -82,8 +82,8 @@ streamUnpickleElem p x = do
Right r -> return r Right r -> return r
-- This is the conduit sink that handles the stream XML events. We extend it -- This is the conduit sink that handles the stream XML events. We extend it
-- with ErrorT capabilities. -- with ExceptT capabilities.
type StreamSink a = ConduitM Event Void (ErrorT XmppFailure IO) a type StreamSink a = ConduitM Event Void (ExceptT XmppFailure IO) a
-- Discards all events before the first EventBeginElement. -- Discards all events before the first EventBeginElement.
throwOutJunk :: Monad m => ConduitM Event a m () 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 -- generated, the connection to the server will be closed, and a XmppFailure
-- will be produced. -- will be produced.
startStream :: StateT StreamState IO (Either XmppFailure ()) startStream :: StateT StreamState IO (Either XmppFailure ())
startStream = runErrorT $ do startStream = runExceptT $ do
lift $ lift $ debugM "Pontarius.Xmpp" "Starting stream..." lift $ lift $ debugM "Pontarius.Xmpp" "Starting stream..."
st <- lift $ get st <- lift $ get
-- Set the `from' (which is also the expected to) attribute depending on the -- 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." lift $ lift $ errorM "Pontarius.Xmpp" "Server sent no hostname."
throwError XmppOtherFailure throwError XmppOtherFailure
Just address -> do Just address -> do
ErrorT $ pushXmlDecl ExceptT $ pushXmlDecl
ErrorT . pushOpenElement . streamNSHack $ ExceptT . pushOpenElement . streamNSHack $
pickleElem xpStream ( "1.0" pickleElem xpStream ( "1.0"
, expectedTo , expectedTo
, Just (Jid Nothing (Nonempty address) Nothing) , Just (Jid Nothing (Nonempty address) Nothing)
, Nothing , Nothing
, preferredLang $ streamConfiguration st , preferredLang $ streamConfiguration st
) )
response <- ErrorT $ runEventsSink $ streamS expectedTo response <- ExceptT $ runEventsSink $ streamS expectedTo
case response of case response of
Right (ver, from, to, sid, lt, features) Right (ver, from, to, sid, lt, features)
| versionFromText ver == Nothing -> closeStreamWithError | versionFromText ver == Nothing -> closeStreamWithError
@ -181,14 +181,14 @@ startStream = runErrorT $ do
| (isJust $ namePrefix name) && (fromJust (namePrefix name) /= "stream") -> | (isJust $ namePrefix name) && (fromJust (namePrefix name) /= "stream") ->
closeStreamWithError StreamBadNamespacePrefix Nothing closeStreamWithError StreamBadNamespacePrefix Nothing
"Root name prefix set and not stream" "Root name prefix set and not stream"
| otherwise -> ErrorT $ checkchildren (flattenAttrs attrs) | otherwise -> ExceptT $ checkchildren (flattenAttrs attrs)
where where
-- HACK: We include the default namespace to make isode's M-LINK server happy. -- HACK: We include the default namespace to make isode's M-LINK server happy.
streamNSHack e = e{elementAttributes = elementAttributes e streamNSHack e = e{elementAttributes = elementAttributes e
++ [( "xmlns" ++ [( "xmlns"
, [ContentText "jabber:client"])]} , [ContentText "jabber:client"])]}
closeStreamWithError :: StreamErrorCondition -> Maybe Element -> String closeStreamWithError :: StreamErrorCondition -> Maybe Element -> String
-> ErrorT XmppFailure (StateT StreamState IO) () -> ExceptT XmppFailure (StateT StreamState IO) ()
closeStreamWithError sec el msg = do closeStreamWithError sec el msg = do
void . lift . pushElement . pickleElem xpStreamError void . lift . pushElement . pickleElem xpStreamError
$ StreamErrorInfo sec Nothing el $ StreamErrorInfo sec Nothing el
@ -200,19 +200,19 @@ startStream = runErrorT $ do
ver' = lookup "version" children ver' = lookup "version" children
xl = lookup xmlLang children xl = lookup xmlLang children
in case () of () | Just Nothing == fmap jidFromText to' -> in case () of () | Just Nothing == fmap jidFromText to' ->
runErrorT $ closeStreamWithError runExceptT $ closeStreamWithError
StreamBadNamespacePrefix Nothing StreamBadNamespacePrefix Nothing
"stream to not a valid JID" "stream to not a valid JID"
| Nothing == ver' -> | Nothing == ver' ->
runErrorT $ closeStreamWithError runExceptT $ closeStreamWithError
StreamUnsupportedVersion Nothing StreamUnsupportedVersion Nothing
"stream no version" "stream no version"
| Just (Nothing :: Maybe LangTag) == (safeRead <$> xl) -> | Just (Nothing :: Maybe LangTag) == (safeRead <$> xl) ->
runErrorT $ closeStreamWithError runExceptT $ closeStreamWithError
StreamInvalidXml Nothing StreamInvalidXml Nothing
"stream no language tag" "stream no language tag"
| otherwise -> | otherwise ->
runErrorT $ closeStreamWithError runExceptT $ closeStreamWithError
StreamBadFormat Nothing StreamBadFormat Nothing
"" ""
safeRead x = case reads $ Text.unpack x of 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 -- 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 -- xml-entities are sent with the same packet and we don't want to eternally
-- block the StreamState while waiting for data to arrive -- block the StreamState while waiting for data to arrive
bufferSrc :: Source (ErrorT XmppFailure IO) o bufferSrc :: Source (ExceptT XmppFailure IO) o
-> IO (ConduitM i o (ErrorT XmppFailure IO) ()) -> IO (ConduitM i o (ExceptT XmppFailure IO) ())
bufferSrc src = do bufferSrc src = do
ref <- newTMVarIO $ DCI.sealConduitT src ref <- newTMVarIO $ DCI.sealConduitT src
let go = do let go = do
@ -290,7 +290,7 @@ bufferSrc src = do
(atomically $ takeTMVar ref) (atomically $ takeTMVar ref)
(\_ -> atomically . putTMVar ref $ zeroResumableSource) (\_ -> atomically . putTMVar ref $ zeroResumableSource)
(\s -> do (\s -> do
res <- runErrorT (s $$++ await) res <- runExceptT (s $$++ await)
case res of case res of
Left e -> do Left e -> do
atomically $ putTMVar ref zeroResumableSource 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 -- | Connects to the XMPP server and opens the XMPP stream against the given
-- realm. -- realm.
openStream :: HostName -> StreamConfiguration -> IO (Either XmppFailure (Stream)) openStream :: HostName -> StreamConfiguration -> IO (Either XmppFailure (Stream))
openStream realm config = runErrorT $ do openStream realm config = runExceptT $ do
lift $ debugM "Pontarius.Xmpp" "Opening stream..." lift $ debugM "Pontarius.Xmpp" "Opening stream..."
stream' <- createStream realm config stream' <- createStream realm config
ErrorT . liftIO $ withStream startStream stream' ExceptT . liftIO $ withStream startStream stream'
return stream' return stream'
-- | Send \"</stream:stream>\" and wait for the server to finish processing and -- | Send \"</stream:stream>\" 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 -- `Connect-and-resumes' the given sink to the stream source, and pulls a
-- `b' value. -- `b' value.
runEventsSink :: Sink Event (ErrorT XmppFailure IO) b runEventsSink :: Sink Event (ExceptT XmppFailure IO) b
-> StateT StreamState IO (Either XmppFailure b) -> StateT StreamState IO (Either XmppFailure b)
runEventsSink snk = do -- TODO: Wrap exceptions? runEventsSink snk = do -- TODO: Wrap exceptions?
src <- gets streamEventSource src <- gets streamEventSource
lift . runErrorT $ src $$ snk lift . runExceptT $ src $$ snk
pullElement :: StateT StreamState IO (Either XmppFailure Element) pullElement :: StateT StreamState IO (Either XmppFailure Element)
pullElement = do pullElement = do
@ -543,7 +543,7 @@ xmppNoStream = StreamState {
, streamConfiguration = def , streamConfiguration = def
} }
zeroSource :: Source (ErrorT XmppFailure IO) a zeroSource :: Source (ExceptT XmppFailure IO) a
zeroSource = do zeroSource = do
liftIO $ debugM "Pontarius.Xmpp" "zeroSource" liftIO $ debugM "Pontarius.Xmpp" "zeroSource"
throwError XmppNoStream throwError XmppNoStream
@ -559,11 +559,11 @@ handleToStreamHandle h = StreamHandle { streamSend = \d ->
, streamClose = hClose h , streamClose = hClose h
} }
createStream :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (Stream) createStream :: HostName -> StreamConfiguration -> ExceptT XmppFailure IO (Stream)
createStream realm config = do createStream realm config = do
result <- connect realm config result <- connect realm config
case result of case result of
Just hand -> ErrorT $ do Just hand -> ExceptT $ do
debugM "Pontarius.Xmpp" "Acquired handle." debugM "Pontarius.Xmpp" "Acquired handle."
debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle." debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle."
eSource <- liftIO . bufferSrc $ eSource <- liftIO . bufferSrc $
@ -598,7 +598,7 @@ createStream realm config = do
maybeSetTlsHost host = over tlsIdentL (updateHost host) maybeSetTlsHost host = over tlsIdentL (updateHost host)
-- Connects using the specified method. Returns the Handle acquired, if any. -- 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) (Maybe StreamHandle)
connect realm config = do connect realm config = do
case connectionDetails config of case connectionDetails config of
@ -626,7 +626,7 @@ connect realm config = do
return . Just $ handleToStreamHandle h' return . Just $ handleToStreamHandle h'
UseConnection mkC -> Just <$> mkC UseConnection mkC -> Just <$> mkC
connectSrv :: ResolvConf -> String -> ErrorT XmppFailure IO (Maybe Handle) connectSrv :: ResolvConf -> String -> ExceptT XmppFailure IO (Maybe Handle)
connectSrv config host = do connectSrv config host = do
case checkHostName (Text.pack host) of case checkHostName (Text.pack host) of
Just host' -> do Just host' -> do
@ -735,8 +735,8 @@ rethrowErrorCall action = do
-- Provides a list of A(AAA) names and port numbers upon a successful -- Provides a list of A(AAA) names and port numbers upon a successful
-- DNS-SRV request, or `Nothing' if the DNS-SRV request failed. -- DNS-SRV request, or `Nothing' if the DNS-SRV request failed.
srvLookup :: Text -> ResolvSeed -> ErrorT XmppFailure IO (Maybe [(Domain, Word16)]) srvLookup :: Text -> ResolvSeed -> ExceptT XmppFailure IO (Maybe [(Domain, Word16)])
srvLookup realm resolvSeed = ErrorT $ do srvLookup realm resolvSeed = ExceptT $ do
result <- Ex.try $ rethrowErrorCall $ withResolver resolvSeed result <- Ex.try $ rethrowErrorCall $ withResolver resolvSeed
$ \resolver -> do $ \resolver -> do
srvResult <- lookupSRV resolver $ BSC8.pack $ "_xmpp-client._tcp." ++ (Text.unpack realm) ++ "." srvResult <- lookupSRV resolver $ BSC8.pack $ "_xmpp-client._tcp." ++ (Text.unpack realm) ++ "."
@ -818,8 +818,8 @@ pushIQ :: Text
-> Element -> Element
-> Stream -> Stream
-> IO (Either XmppFailure (Either IQError IQResult)) -> IO (Either XmppFailure (Either IQError IQResult))
pushIQ iqID to tp lang body stream = runErrorT $ do pushIQ iqID to tp lang body stream = runExceptT $ do
ErrorT $ pushStanza ExceptT $ pushStanza
(IQRequestS $ IQRequest iqID Nothing to lang tp body []) stream (IQRequestS $ IQRequest iqID Nothing to lang tp body []) stream
res <- lift $ pullStanza stream res <- lift $ pullStanza stream
case res of case res of

8
source/Network/Xmpp/Tls.hs
Unescape View File

@ -9,7 +9,7 @@ module Network.Xmpp.Tls where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import qualified Control.Exception.Lifted as Ex import qualified Control.Exception.Lifted as Ex
import Control.Monad import Control.Monad
import Control.Monad.Error import Control.Monad.Except
import Control.Monad.State.Strict import Control.Monad.State.Strict
import "crypto-random" Crypto.Random import "crypto-random" Crypto.Random
import qualified Data.ByteString as BS 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 -- error monad. Join unifies them into one error layer
. wrapExceptions . wrapExceptions
. flip withStream con . flip withStream con
. runErrorT $ do . runExceptT $ do
conf <- gets streamConfiguration conf <- gets streamConfiguration
sState <- gets streamConnectionState sState <- gets streamConnectionState
case sState of case sState of
@ -85,7 +85,7 @@ tls con = fmap join -- We can have Left values both from exceptions and the
startTls = do startTls = do
liftIO $ infoM "Pontarius.Xmpp.Tls" "Running StartTLS" liftIO $ infoM "Pontarius.Xmpp.Tls" "Running StartTLS"
params <- gets $ tlsParams . streamConfiguration params <- gets $ tlsParams . streamConfiguration
ErrorT $ pushElement starttlsE ExceptT $ pushElement starttlsE
answer <- lift $ pullElement answer <- lift $ pullElement
case answer of case answer of
Left e -> throwError e 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 -> ClientParams -- ^ TLS parameters to use when securing the connection
-> String -- ^ Host to use when connecting (will be resolved -> String -- ^ Host to use when connecting (will be resolved
-- using SRV records) -- using SRV records)
-> ErrorT XmppFailure IO StreamHandle -> ExceptT XmppFailure IO StreamHandle
connectTls config params host = do connectTls config params host = do
h <- connectSrv config host >>= \h' -> case h' of h <- connectSrv config host >>= \h' -> case h' of
Nothing -> throwError TcpConnectionFailure Nothing -> throwError TcpConnectionFailure

10
source/Network/Xmpp/Types.hs
Unescape View File

@ -89,7 +89,7 @@ module Network.Xmpp.Types
import Control.Applicative ((<$>), (<|>), many) import Control.Applicative ((<$>), (<|>), many)
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Exception import Control.Exception
import Control.Monad.Error import Control.Monad.Except
import qualified Data.Attoparsec.Text as AP import qualified Data.Attoparsec.Text as AP
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.Char (isSpace) import Data.Char (isSpace)
@ -623,7 +623,6 @@ data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream
deriving (Show, Eq, Typeable) deriving (Show, Eq, Typeable)
instance Exception XmppFailure instance Exception XmppFailure
instance Error XmppFailure where noMsg = XmppOtherFailure
-- | Signals a SASL authentication error condition. -- | Signals a SASL authentication error condition.
data AuthFailure = -- | No mechanism offered by the server was matched 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 | AuthOtherFailure
deriving (Eq, Show) deriving (Eq, Show)
instance Error AuthFailure where
noMsg = AuthOtherFailure
-- ============================================================================= -- =============================================================================
-- XML TYPES -- XML TYPES
-- ============================================================================= -- =============================================================================
@ -791,7 +787,7 @@ data StreamState = StreamState
-- | Functions to send, receive, flush, and close the stream -- | Functions to send, receive, flush, and close the stream
, streamHandle :: StreamHandle , streamHandle :: StreamHandle
-- | Event conduit source, and its associated finalizer -- | 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 -- | Stream features advertised by the server
, streamFeatures :: !StreamFeatures -- TODO: Maybe? , streamFeatures :: !StreamFeatures -- TODO: Maybe?
-- | The hostname or IP specified for the connection -- | The hostname or IP specified for the connection
@ -1229,7 +1225,7 @@ data ConnectionDetails = UseRealm -- ^ Use realm to resolv host. This is the
-- default. -- default.
| UseSrv HostName -- ^ Use this hostname for a SRV lookup | UseSrv HostName -- ^ Use this hostname for a SRV lookup
| UseHost HostName PortNumber -- ^ Use specified host | 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 -- ^ Use a custom method to create a StreamHandle. This
-- will also be used by reconnect. For example, to -- will also be used by reconnect. For example, to
-- establish TLS before starting the stream as done by -- establish TLS before starting the stream as done by

20
source/Network/Xmpp/Xep/InbandRegistration.hs
Unescape View File

@ -11,7 +11,7 @@ module Network.Xmpp.Xep.InbandRegistration where
import Control.Applicative((<$>)) import Control.Applicative((<$>))
import Control.Arrow(left) import Control.Arrow(left)
import Control.Exception import Control.Exception
import Control.Monad.Error import Control.Monad.Except
import Control.Monad.State import Control.Monad.State
import Data.Either (partitionEithers) import Data.Either (partitionEithers)
@ -35,8 +35,6 @@ data IbrError = IbrNotSupported
| IbrTimeout | IbrTimeout
deriving (Show) deriving (Show)
instance Error IbrError
data Query = Query { instructions :: Maybe Text.Text data Query = Query { instructions :: Maybe Text.Text
, registered :: Bool , registered :: Bool
@ -82,8 +80,6 @@ data RegisterError = IbrError IbrError
| AlreadyRegistered | AlreadyRegistered
deriving (Show) deriving (Show)
instance Error RegisterError
mapError f = mapErrorT (liftM $ left f) mapError f = mapErrorT (liftM $ left f)
-- | Retrieve the necessary fields and fill them in to register an account with -- | 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)] registerWith :: [(Field, Text.Text)]
-> Stream -> Stream
-> IO (Either RegisterError Query) -> IO (Either RegisterError Query)
registerWith givenFields con = runErrorT $ do registerWith givenFields con = runExceptT $ do
fs <- mapError IbrError . ErrorT $ requestFields con fs <- mapError IbrError . ExceptT $ requestFields con
when (registered fs) . throwError $ AlreadyRegistered when (registered fs) . throwError $ AlreadyRegistered
let res = flip map (fields fs) $ \(field,_) -> let res = flip map (fields fs) $ \(field,_) ->
case lookup field givenFields of case lookup field givenFields of
@ -101,18 +97,18 @@ registerWith givenFields con = runErrorT $ do
fields <- case partitionEithers res of fields <- case partitionEithers res of
([],fs) -> return fs ([],fs) -> return fs
(fs,_) -> throwError $ MissingFields 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 return result
createAccountWith host hostname port fields = runErrorT $ do createAccountWith host hostname port fields = runExceptT $ do
con' <- liftIO $ connectTcp host port hostname con' <- liftIO $ connectTcp host port hostname
con <- case con' of con <- case con' of
Left e -> throwError $ IbrError IbrNoConnection Left e -> throwError $ IbrError IbrNoConnection
Right r -> return r Right r -> return r
lift $ startTLS exampleParams con lift $ startTLS exampleParams con
ErrorT $ registerWith fields con ExceptT $ registerWith fields con
deleteAccount host hostname port username password = do deleteAccount host hostname port username password = do
con <- simpleConnect host port hostname username password Nothing 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' :: Session -> IO (Either IbrError Query)
unregister' = query' Set $ emptyQuery {remove = True} unregister' = query' Set $ emptyQuery {remove = True}
requestFields con = runErrorT $ do requestFields con = runExceptT $ do
qr <- ErrorT $ query Get emptyQuery con qr <- ExceptT $ query Get emptyQuery con
return $ qr return $ qr
xpQuery :: PU [XML.Node] Query xpQuery :: PU [XML.Node] Query

4
source/Network/Xmpp/Xep/ServiceDiscovery.hs
Unescape View File

@ -17,7 +17,7 @@ module Network.Xmpp.Xep.ServiceDiscovery
where where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Monad.Error import Control.Monad.Except
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.XML.Pickle import Data.XML.Pickle
@ -36,8 +36,6 @@ data DiscoError = DiscoNoQueryElement
deriving (Show) deriving (Show)
instance Error DiscoError
-- Identity -- Identity
--------------------- ---------------------

Write Preview
Loading…
Cancel
Save