pontarius-xmpp 0.5.4 → 0.5.5
raw patch · 15 files changed
+133/−125 lines, 15 filesdep ~conduitdep ~dnssetup-changed
Dependency ranges changed: conduit, dns
Files
- Setup.hs +13/−10
- pontarius-xmpp.cabal +9/−5
- source/Network/Xmpp/Concurrent.hs +9/−9
- source/Network/Xmpp/Concurrent/IQ.hs +1/−1
- source/Network/Xmpp/Concurrent/Threads.hs +1/−1
- source/Network/Xmpp/Concurrent/Types.hs +2/−2
- source/Network/Xmpp/Marshal.hs +9/−9
- source/Network/Xmpp/Sasl.hs +10/−10
- source/Network/Xmpp/Sasl/Common.hs +11/−11
- source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +4/−4
- source/Network/Xmpp/Sasl/Mechanisms/Plain.hs +3/−3
- source/Network/Xmpp/Sasl/Mechanisms/Scram.hs +4/−4
- source/Network/Xmpp/Stream.hs +36/−35
- source/Network/Xmpp/Tls.hs +4/−4
- source/Network/Xmpp/Types.hs +17/−17
Setup.hs view
@@ -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
pontarius-xmpp.cabal view
@@ -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
source/Network/Xmpp/Concurrent.hs view
@@ -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
source/Network/Xmpp/Concurrent/IQ.hs view
@@ -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
source/Network/Xmpp/Concurrent/Threads.hs view
@@ -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
source/Network/Xmpp/Concurrent/Types.hs view
@@ -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 ()
source/Network/Xmpp/Marshal.hs view
@@ -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
source/Network/Xmpp/Sasl.hs view
@@ -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..."
source/Network/Xmpp/Sasl/Common.hs view
@@ -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
source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs view
@@ -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
source/Network/Xmpp/Sasl/Mechanisms/Plain.hs view
@@ -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
source/Network/Xmpp/Sasl/Mechanisms/Scram.hs view
@@ -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
source/Network/Xmpp/Stream.hs view
@@ -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 \"</stream:stream>\" 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
source/Network/Xmpp/Tls.hs view
@@ -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
source/Network/Xmpp/Types.hs view
@@ -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