diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -2,17 +2,19 @@ {-# OPTIONS_GHC -Wall #-} module Main (main) where -import Data.List ( nub ) -import Data.Version ( showVersion ) -import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName ) +import Distribution.Package ( PackageName, Package, PackageId, InstalledPackageId, packageVersion, packageName, unPackageName ) import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) -import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles ) +import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles, ordNub ) import Distribution.Simple.BuildPaths ( autogenModulesDir ) import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref)) import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) import Distribution.Text ( display ) +import Distribution.Types.MungedPackageId ( MungedPackageId(mungedName, mungedVersion) ) +import Distribution.Types.MungedPackageName ( MungedPackageName, unMungedPackageName ) +import Distribution.Types.UnqualComponentName ( unUnqualComponentName ) import Distribution.Verbosity ( Verbosity, normal ) +import Distribution.Version ( showVersion ) import System.FilePath ( () ) main :: IO () @@ -28,15 +30,16 @@ createDirectoryIfMissingVerbose verbosity True dir withLibLBI pkg lbi $ \_ libcfg -> do withTestLBI pkg lbi $ \suite suitecfg -> do - rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines - [ "module Build_" ++ testName suite ++ " where" + let testSuiteName = unUnqualComponentName (testName suite) + rewriteFile (dir "Build_" ++ testSuiteName ++ ".hs") $ unlines + [ "module Build_" ++ testSuiteName ++ " where" , "deps :: [String]" , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) ] where formatdeps = map (formatone . snd) - formatone p = case packageName p of - PackageName n -> n ++ "-" ++ showVersion (packageVersion p) + formatone p = + unMungedPackageName (mungedName p) ++ "-" ++ showVersion (mungedVersion p) -testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] -testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys +testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, MungedPackageId)] +testDeps xs ys = ordNub $ componentPackageDeps xs ++ componentPackageDeps ys diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -1,5 +1,5 @@ Name: pontarius-xmpp -Version: 0.5.4 +Version: 0.5.5 Cabal-Version: >= 1.9.2 Build-Type: Custom License: BSD3 @@ -32,6 +32,11 @@ Default: True } +custom-setup + setup-depends: base + , Cabal >= 2.0.1.0 + , filepath + Library hs-source-dirs: source Exposed: True @@ -39,14 +44,14 @@ , base >4 && <5 , base64-bytestring >=0.1.0.0 , binary >=0.4.1 - , conduit >=1.2.4.2 && < 1.3 + , conduit >=1.3 && < 1.4 , containers >=0.4.0.0 , crypto-api >=0.9 , crypto-random >=0.0.5 , cryptohash >=0.6.1 , cryptohash-cryptoapi >=0.1 , data-default >=0.2 - , dns >=0.3.0 + , dns >=3.0 , exceptions >=0.6 , hslogger >=1.1.0 , iproute >=1.2.4 @@ -83,7 +88,7 @@ , Network.Xmpp.IM , Network.Xmpp.Internal , Network.Xmpp.Lens - Other-modules: Network.Xmpp.Concurrent + , Network.Xmpp.Concurrent , Network.Xmpp.Concurrent.Basic , Network.Xmpp.Concurrent.IQ , Network.Xmpp.Concurrent.Message @@ -96,7 +101,6 @@ , Network.Xmpp.IM.PresenceTracker , Network.Xmpp.IM.Roster , Network.Xmpp.IM.Roster.Types - , Network.Xmpp.IM.PresenceTracker , Network.Xmpp.IM.PresenceTracker.Types , Network.Xmpp.Marshal , Network.Xmpp.Sasl diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -24,7 +24,7 @@ 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 @@ -> 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 @@ , 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 @@ (\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 @@ -> 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 --- a/source/Network/Xmpp/Concurrent/IQ.hs +++ b/source/Network/Xmpp/Concurrent/IQ.hs @@ -9,7 +9,7 @@ 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 --- a/source/Network/Xmpp/Concurrent/Threads.hs +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -9,7 +9,7 @@ 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 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -7,7 +7,7 @@ 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 @@ 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/Marshal.hs b/source/Network/Xmpp/Marshal.hs --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -23,15 +23,15 @@ xpNonemptyText = ("xpNonemptyText" , "") xpWrap Nonempty fromNonempty xpText xpStreamElement :: PU [Node] (Either StreamErrorInfo XmppElement) -xpStreamElement = xpEither xpStreamError $ - xpWrap (\v -> case v of - Left l -> XmppStanza l - Right r -> XmppNonza r - ) - ( \v -> case v of - XmppStanza l -> Left l - XmppNonza r -> Right r) - $ xpEither xpStanza xpElemVerbatim +xpStreamElement = xpEither xpStreamError $ xpAlt elemSel + [ xpWrap XmppStanza (\(XmppStanza x) -> x) xpStanza + , xpWrap XmppNonza (\(XmppNonza x) -> x) xpElemVerbatim + ] + where + -- Selector for which pickler to execute above. + elemSel :: XmppElement -> Int + elemSel (XmppStanza _) = 0 + elemSel (XmppNonza _) = 1 xpStreamStanza :: PU [Node] (Either StreamErrorInfo Stanza) xpStreamStanza = xpEither xpStreamError xpStanza diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -14,7 +14,7 @@ , 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 @@ 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 @@ 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 @@ -> 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 @@ -- 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 --- 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 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 @@ 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 @@ 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 @@ 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 @@ _ -> 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 @@ -- | 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 @@ 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 @@ -- | 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 --- a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs @@ -5,7 +5,7 @@ ( 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 @@ 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 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 --- a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs @@ -8,7 +8,7 @@ ( 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 @@ 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 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 --- a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs @@ -7,7 +7,7 @@ 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 @@ -> 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 @@ 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 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 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -15,7 +15,7 @@ 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 @@ -33,6 +33,7 @@ import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding.Error as Text import Data.Void (Void) +import Data.Word (Word16) import Data.XML.Pickle import Data.XML.Types import qualified GHC.IO.Exception as GIE @@ -81,8 +82,8 @@ 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 () @@ -109,7 +110,7 @@ -- 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 @@ -127,15 +128,15 @@ 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 @@ -180,14 +181,14 @@ | (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 @@ -199,19 +200,19 @@ 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 @@ -280,16 +281,16 @@ -- 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.newResumableSource src + ref <- newTMVarIO $ DCI.sealConduitT src let go = do dt <- liftIO $ Ex.bracketOnError (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 @@ -304,7 +305,7 @@ Right (Just d) -> yield d >> go return go where - zeroResumableSource = DCI.newResumableSource zeroSource + zeroResumableSource = DCI.sealConduitT zeroSource -- Reads the (partial) stream:stream and the server features from the stream. -- Returns the (unvalidated) stream attributes, the unparsed element, or @@ -348,10 +349,10 @@ -- | 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 @@ -454,11 +455,11 @@ -- `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 @@ -542,7 +543,7 @@ , streamConfiguration = def } -zeroSource :: Source (ErrorT XmppFailure IO) a +zeroSource :: Source (ExceptT XmppFailure IO) a zeroSource = do liftIO $ debugM "Pontarius.Xmpp" "zeroSource" throwError XmppNoStream @@ -558,11 +559,11 @@ , 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 $ @@ -597,7 +598,7 @@ 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 @@ -625,7 +626,7 @@ 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 @@ -734,8 +735,8 @@ -- 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, Int)]) -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) ++ "." @@ -764,13 +765,13 @@ -- 2782. It sorts the SRV results in order of priority, and then -- uses a random process to order the records with the same -- priority based on their weight. - orderSrvResult :: [(Int, Int, Int, Domain)] -> IO [(Int, Int, Int, Domain)] + orderSrvResult :: [(Word16, Word16, Word16, Domain)] -> IO [(Word16, Word16, Word16, Domain)] orderSrvResult srvResult = do -- Order the result set by priority. let srvResult' = sortBy (comparing (\(priority, _, _, _) -> priority)) srvResult -- Group elements in sublists based on their priority. The - -- type is `[[(Int, Int, Int, Domain)]]'. - let srvResult'' = Data.List.groupBy (\(priority, _, _, _) (priority', _, _, _) -> priority == priority') srvResult' :: [[(Int, Int, Int, Domain)]] + -- type is `[[(Word16, Word16, Word16, Domain)]]'. + let srvResult'' = Data.List.groupBy (\(priority, _, _, _) (priority', _, _, _) -> priority == priority') srvResult' :: [[(Word16, Word16, Word16, Domain)]] -- For each sublist, put records with a weight of zero first. let srvResult''' = Data.List.map (\sublist -> let (a, b) = partition (\(_, weight, _, _) -> weight == 0) sublist in Data.List.concat [a, b]) srvResult'' -- Order each sublist. @@ -778,7 +779,7 @@ -- Concatinated the results. return $ Data.List.concat srvResult'''' where - orderSublist :: [(Int, Int, Int, Domain)] -> IO [(Int, Int, Int, Domain)] + orderSublist :: [(Word16, Word16, Word16, Domain)] -> IO [(Word16, Word16, Word16, Domain)] orderSublist [] = return [] orderSublist sublist = do -- Compute the running sum, as well as the total sum of @@ -817,8 +818,8 @@ -> 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 --- a/source/Network/Xmpp/Tls.hs +++ b/source/Network/Xmpp/Tls.hs @@ -9,7 +9,7 @@ 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 @@ -- 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 @@ 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 @@ -> 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 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -89,12 +89,13 @@ 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) import Data.Conduit import Data.Default +import Data.Semigroup as Sem import qualified Data.Set as Set import Data.String (IsString, fromString) import Data.Text (Text) @@ -623,7 +624,6 @@ 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 +641,6 @@ | AuthOtherFailure deriving (Eq, Show) -instance Error AuthFailure where - noMsg = AuthOtherFailure - -- ============================================================================= -- XML TYPES -- ============================================================================= @@ -739,16 +736,8 @@ -- TODO: All feature elements instead? } deriving (Eq, Show) -instance Monoid StreamFeatures where - mempty = StreamFeatures - { streamFeaturesTls = Nothing - , streamFeaturesMechanisms = [] - , streamFeaturesRosterVer = Nothing - , streamFeaturesPreApproval = False - , streamFeaturesSession = Nothing - , streamFeaturesOther = [] - } - mappend sf1 sf2 = +instance Sem.Semigroup StreamFeatures where + sf1 <> sf2 = StreamFeatures { streamFeaturesTls = mplusOn streamFeaturesTls , streamFeaturesMechanisms = mplusOn streamFeaturesMechanisms @@ -763,6 +752,17 @@ where mplusOn f = f sf1 `mplus` f sf2 +instance Monoid StreamFeatures where + mempty = StreamFeatures + { streamFeaturesTls = Nothing + , streamFeaturesMechanisms = [] + , streamFeaturesRosterVer = Nothing + , streamFeaturesPreApproval = False + , streamFeaturesSession = Nothing + , streamFeaturesOther = [] + } + mappend = (<>) + -- | Signals the state of the stream connection. data ConnectionState = Closed -- ^ Stream has not been established yet @@ -791,7 +791,7 @@ -- | 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 +1229,7 @@ -- 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