From b4b2610880b9c8bfb661271ca0df585fb08f0449 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 29 Apr 2012 17:08:51 +0200 Subject: [PATCH] Renamed SaslError to AuthError Renamed SASLError to SaslError added BufferedSource Changed sources to be buffered reader now only reads the connection state in the beginning, doesn't need to put anything back Updated test client --- pontarius.cabal | 1 + src/Data/Conduit/BufferedSource.hs | 20 +++++++ src/Network/XMPP.hs | 6 +- src/Network/XMPP/Concurrent/Threads.hs | 21 +++---- src/Network/XMPP/Monad.hs | 6 +- src/Network/XMPP/SASL.hs | 39 ++++++------- src/Network/XMPP/Stream.hs | 5 +- src/Network/XMPP/Types.hs | 78 +++++++++++++------------- src/Tests.hs | 14 ++--- 9 files changed, 105 insertions(+), 85 deletions(-) create mode 100644 src/Data/Conduit/BufferedSource.hs diff --git a/pontarius.cabal b/pontarius.cabal index 8dc8918..ff0b9a8 100644 --- a/pontarius.cabal +++ b/pontarius.cabal @@ -69,6 +69,7 @@ Library , Network.XMPP.Concurrent.Threads , Network.XMPP.Concurrent.Monad , Text.XML.Stream.Elements + , Data.Conduit.BufferedSource , Data.Conduit.TLS GHC-Options: -Wall diff --git a/src/Data/Conduit/BufferedSource.hs b/src/Data/Conduit/BufferedSource.hs new file mode 100644 index 0000000..c755509 --- /dev/null +++ b/src/Data/Conduit/BufferedSource.hs @@ -0,0 +1,20 @@ +module Data.Conduit.BufferedSource where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.IORef +import Data.Conduit +import qualified Data.Conduit.List as CL + +-- | Buffered source from conduit 0.3 +bufferSource :: MonadIO m => Source m o -> IO (Source m o) +bufferSource s = do + srcRef <- newIORef s + return $ do + src <- liftIO $ readIORef srcRef + let go src = do + (src', res) <- lift $ src $$+ CL.head + case res of + Nothing -> return () + Just x -> liftIO (writeIORef srcRef src') >> yield x >> go src' + in go src diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index 1c87cb9..84bf2be 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -84,8 +84,10 @@ module Network.XMPP -- , Message , MessageError + , MessageType(..) -- *** creating - , module Network.XMPP.Message + , simpleMessage + , answerMessage -- *** sending , sendMessage -- *** receiving @@ -174,7 +176,7 @@ auth :: Text.Text -- ^ The username -> Text.Text -- ^ The password -> Maybe Text -- ^ The desired resource or 'Nothing' to let the server -- assign one - -> XMPP (Either SaslError Text.Text) + -> XMPP (Either AuthError Text.Text) auth username passwd resource = runErrorT $ do ErrorT . withConnection $ xmppSASL username passwd res <- lift $ xmppBind resource diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs index 7230205..5377d37 100644 --- a/src/Network/XMPP/Concurrent/Threads.hs +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -44,17 +44,13 @@ readWorker :: TChan (Either MessageError Message) -> IO () readWorker messageC presenceC handlers stateRef = Ex.mask_ . forever $ do - res <- liftIO $ Ex.catch ( - Ex.bracket - (atomically $ takeTMVar stateRef) - (atomically . putTMVar stateRef ) - (\s -> do - -- we don't know whether pull will - -- necessarily be interruptible - allowInterrupt - Just <$> runStateT pullStanza s - ) - ) + res <- liftIO $ Ex.catch ( do + -- we don't know whether pull will + -- necessarily be interruptible + s <- liftIO . atomically $ readTMVar stateRef + allowInterrupt + Just <$> runStateT pullStanza s + ) (\(Interrupt t) -> do void $ handleInterrupts [t] return Nothing @@ -62,8 +58,7 @@ readWorker messageC presenceC handlers stateRef = liftIO . atomically $ do case res of Nothing -> return () - Just (sta, s') -> do - putTMVar stateRef s' + Just (sta, _s) -> do case sta of MessageS m -> do writeTChan messageC $ Right m _ <- readTChan messageC -- Sic! diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index e5a8b23..34bc566 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -13,6 +13,7 @@ import Control.Monad.State.Strict import Data.ByteString as BS import Data.Conduit +import Data.Conduit.BufferedSource import Data.Conduit.Binary as CB import Data.Text(Text) import Data.XML.Pickle @@ -45,8 +46,7 @@ pushOpen e = do pullSink :: Sink Event IO b -> XMPPConMonad b pullSink snk = do source <- gets sConSrc - (src', r) <- lift $ source $$+ snk - modify $ (\s -> s {sConSrc = src'}) + (_, r) <- lift $ source $$+ snk return r pullElement :: XMPPConMonad Element @@ -114,7 +114,7 @@ xmppRawConnect host hostname = do hSetBuffering con NoBuffering return con let raw = sourceHandle con - let src = raw $= XP.parseBytes def + src <- liftIO . bufferSource $ raw $= XP.parseBytes def let st = XMPPConState src (raw) diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 87e3325..b5897bf 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -51,16 +51,17 @@ saslResponse2E = [] [] -data SaslError = SaslXmlError - | SaslMechanismError [Text] - | SaslChallengeError - | SaslStreamError StreamError - | SaslConnectionError +data AuthError = AuthXmlError + | AuthMechanismError [Text] + | AuthChallengeError + | AuthStreamError StreamError + | AuthConnectionError + deriving Show -instance Error SaslError where - noMsg = SaslXmlError +instance Error AuthError where + noMsg = AuthXmlError -xmppSASL:: Text -> Text -> XMPPConMonad (Either SaslError Text) +xmppSASL:: Text -> Text -> XMPPConMonad (Either AuthError Text) xmppSASL uname passwd = runErrorT $ do realm <- gets sHostname case realm of @@ -68,37 +69,37 @@ xmppSASL uname passwd = runErrorT $ do ErrorT $ xmppStartSASL realm' uname passwd modify (\s -> s{sUsername = Just uname}) return uname - Nothing -> throwError SaslConnectionError + Nothing -> throwError AuthConnectionError xmppStartSASL :: Text -> Text -> Text - -> XMPPConMonad (Either SaslError ()) + -> XMPPConMonad (Either AuthError ()) xmppStartSASL realm username passwd = runErrorT $ do mechanisms <- gets $ saslMechanisms . sFeatures unless ("DIGEST-MD5" `elem` mechanisms) - . throwError $ SaslMechanismError mechanisms + . throwError $ AuthMechanismError mechanisms lift . pushN $ saslInitE "DIGEST-MD5" challenge' <- lift $ B64.decode . Text.encodeUtf8 <$> pullPickle challengePickle challenge <- case challenge' of - Left _e -> throwError SaslChallengeError + Left _e -> throwError AuthChallengeError Right r -> return r pairs <- case toPairs challenge of - Left _ -> throwError SaslChallengeError + Left _ -> throwError AuthChallengeError Right p -> return p g <- liftIO $ Random.newStdGen lift . pushN . saslResponseE $ createResponse g realm username passwd pairs challenge2 <- lift $ pullPickle (xpEither failurePickle challengePickle) case challenge2 of - Left _x -> throwError $ SaslXmlError + Left _x -> throwError $ AuthXmlError Right _ -> return () lift $ pushN saslResponse2E e <- lift pullElement case e of Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] -> return () - _ -> throwError SaslXmlError -- TODO: investigate - _ <- ErrorT $ left SaslStreamError <$> xmppRestartStream + _ -> throwError AuthXmlError -- TODO: investigate + _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream return () createResponse :: Random.RandomGen g @@ -186,10 +187,10 @@ md5Digest uname realm password digestURI nc qop nonce cnonce= in hash [ha1,nonce, nc, cnonce,qop,ha2] -- Pickling -failurePickle :: PU [Node] (SASLFailure) +failurePickle :: PU [Node] (SaslFailure) failurePickle = xpWrap (\(txt,(failure,_,_)) - -> SASLFailure failure txt) - (\(SASLFailure failure txt) + -> SaslFailure failure txt) + (\(SaslFailure failure txt) -> (txt,(failure,(),()))) (xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}failure" diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index be79acf..80f3462 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -7,6 +7,7 @@ import Control.Monad.Error import Control.Monad.State.Strict import Data.Conduit +import Data.Conduit.BufferedSource import Data.Conduit.List as CL import Data.Text as T import Data.XML.Pickle @@ -55,14 +56,14 @@ xmppStartStream = runErrorT $ do Nothing -> throwError StreamConnectionError Just hostname -> lift . pushOpen $ pickleElem pickleStream ("1.0",Nothing, Just hostname) - features <- ErrorT . pullSink $ runErrorT xmppStream + features <- ErrorT . pullSink $ runErrorT xmppStream modify (\s -> s {sFeatures = features}) return () xmppRestartStream :: XMPPConMonad (Either StreamError ()) xmppRestartStream = do raw <- gets sRawSrc - let newsrc = raw $= XP.parseBytes def + newsrc <- liftIO . bufferSource $ raw $= XP.parseBytes def modify (\s -> s{sConSrc = newsrc}) xmppStartStream diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index 9013eb2..52009ce 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -25,8 +25,8 @@ module Network.XMPP.Types , Presence(..) , PresenceError(..) , PresenceType(..) - , SASLError(..) - , SASLFailure(..) + , SaslError(..) + , SaslFailure(..) , ServerAddress(..) , ServerFeatures(..) , ShowType(..) @@ -468,67 +468,67 @@ instance Read StanzaErrorCondition where -- OTHER STUFF -- ============================================================================= -data SASLFailure = SASLFailure { saslFailureCondition :: SASLError +data SaslFailure = SaslFailure { saslFailureCondition :: SaslError , saslFailureText :: Maybe ( Maybe LangTag , Text ) } deriving Show -data SASLError = SASLAborted -- ^ Client aborted - | SASLAccountDisabled -- ^ The account has been temporarily +data SaslError = SaslAborted -- ^ Client aborted + | SaslAccountDisabled -- ^ The account has been temporarily -- disabled - | SASLCredentialsExpired -- ^ The authentication failed because + | SaslCredentialsExpired -- ^ The authentication failed because -- the credentials have expired - | SASLEncryptionRequired -- ^ The mechanism requested cannot be + | SaslEncryptionRequired -- ^ The mechanism requested cannot be -- used the confidentiality and -- integrity of the underlying -- stream is protected (typically -- with TLS) - | SASLIncorrectEncoding -- ^ The base64 encoding is incorrect - | SASLInvalidAuthzid -- ^ The authzid has an incorrect + | SaslIncorrectEncoding -- ^ The base64 encoding is incorrect + | SaslInvalidAuthzid -- ^ The authzid has an incorrect -- format or the initiating entity does -- not have the appropriate permissions -- to authorize that ID - | SASLInvalidMechanism -- ^ The mechanism is not supported by + | SaslInvalidMechanism -- ^ The mechanism is not supported by -- the receiving entity - | SASLMalformedRequest -- ^ Invalid syntax - | SASLMechanismTooWeak -- ^ The receiving entity policy + | SaslMalformedRequest -- ^ Invalid syntax + | SaslMechanismTooWeak -- ^ The receiving entity policy -- requires a stronger mechanism - | SASLNotAuthorized -- ^ Invalid credentials + | SaslNotAuthorized -- ^ Invalid credentials -- provided, or some -- generic authentication -- failure has occurred - | SASLTemporaryAuthFailure -- ^ There receiving entity reported a + | SaslTemporaryAuthFailure -- ^ There receiving entity reported a -- temporary error condition; the -- initiating entity is recommended -- to try again later -instance Show SASLError where - show SASLAborted = "aborted" - show SASLAccountDisabled = "account-disabled" - show SASLCredentialsExpired = "credentials-expired" - show SASLEncryptionRequired = "encryption-required" - show SASLIncorrectEncoding = "incorrect-encoding" - show SASLInvalidAuthzid = "invalid-authzid" - show SASLInvalidMechanism = "invalid-mechanism" - show SASLMalformedRequest = "malformed-request" - show SASLMechanismTooWeak = "mechanism-too-weak" - show SASLNotAuthorized = "not-authorized" - show SASLTemporaryAuthFailure = "temporary-auth-failure" - -instance Read SASLError where - readsPrec _ "aborted" = [(SASLAborted , "")] - readsPrec _ "account-disabled" = [(SASLAccountDisabled , "")] - readsPrec _ "credentials-expired" = [(SASLCredentialsExpired , "")] - readsPrec _ "encryption-required" = [(SASLEncryptionRequired , "")] - readsPrec _ "incorrect-encoding" = [(SASLIncorrectEncoding , "")] - readsPrec _ "invalid-authzid" = [(SASLInvalidAuthzid , "")] - readsPrec _ "invalid-mechanism" = [(SASLInvalidMechanism , "")] - readsPrec _ "malformed-request" = [(SASLMalformedRequest , "")] - readsPrec _ "mechanism-too-weak" = [(SASLMechanismTooWeak , "")] - readsPrec _ "not-authorized" = [(SASLNotAuthorized , "")] - readsPrec _ "temporary-auth-failure" = [(SASLTemporaryAuthFailure , "")] +instance Show SaslError where + show SaslAborted = "aborted" + show SaslAccountDisabled = "account-disabled" + show SaslCredentialsExpired = "credentials-expired" + show SaslEncryptionRequired = "encryption-required" + show SaslIncorrectEncoding = "incorrect-encoding" + show SaslInvalidAuthzid = "invalid-authzid" + show SaslInvalidMechanism = "invalid-mechanism" + show SaslMalformedRequest = "malformed-request" + show SaslMechanismTooWeak = "mechanism-too-weak" + show SaslNotAuthorized = "not-authorized" + show SaslTemporaryAuthFailure = "temporary-auth-failure" + +instance Read SaslError where + readsPrec _ "aborted" = [(SaslAborted , "")] + readsPrec _ "account-disabled" = [(SaslAccountDisabled , "")] + readsPrec _ "credentials-expired" = [(SaslCredentialsExpired , "")] + readsPrec _ "encryption-required" = [(SaslEncryptionRequired , "")] + readsPrec _ "incorrect-encoding" = [(SaslIncorrectEncoding , "")] + readsPrec _ "invalid-authzid" = [(SaslInvalidAuthzid , "")] + readsPrec _ "invalid-mechanism" = [(SaslInvalidMechanism , "")] + readsPrec _ "malformed-request" = [(SaslMalformedRequest , "")] + readsPrec _ "mechanism-too-weak" = [(SaslMechanismTooWeak , "")] + readsPrec _ "not-authorized" = [(SaslNotAuthorized , "")] + readsPrec _ "temporary-auth-failure" = [(SaslTemporaryAuthFailure , "")] readsPrec _ _ = [] -- | Readability type for host name Texts. diff --git a/src/Tests.hs b/src/Tests.hs index cca1d1f..ee381c4 100644 --- a/src/Tests.hs +++ b/src/Tests.hs @@ -28,7 +28,7 @@ supervisor :: JID supervisor = read "uart14@species64739.dyndns.org" -attXmpp :: STM a -> XMPPThread a +attXmpp :: STM a -> XMPP a attXmpp = liftIO . atomically testNS :: Text @@ -66,7 +66,7 @@ iqResponder = do answerIQ next (Right $ Just answerBody) when (payloadCounter payload == 10) endSession -autoAccept :: XMPPThread () +autoAccept :: XMPP () autoAccept = forever $ do st <- waitForPresence isPresenceSubscribe sendPresence $ presenceSubscribed (fromJust $ presenceFrom st) @@ -92,7 +92,7 @@ runMain debug number = do let debug' = liftIO . atomically . debug . (("Thread " ++ show number ++ ":") ++) wait <- newEmptyTMVarIO - xmppNewSession $ do + withNewSession $ do setSessionEndHandler (liftIO . atomically $ putTMVar wait ()) debug' "running" connect "localhost" "species64739.dyndns.org" @@ -100,15 +100,15 @@ runMain debug number = do saslResponse <- auth (fromJust $ localpart we) "pwd" (resourcepart we) case saslResponse of Right _ -> return () - Left e -> error "saslerror" + Left e -> error $ show e debug' "session standing" sendPresence presenceOnline - forkXMPP autoAccept + fork autoAccept sendPresence $ presenceSubscribe them - forkXMPP iqResponder + fork iqResponder when active $ do liftIO $ threadDelay 1000000 -- Wait for the other thread to go online - void . forkXMPP $ do + void . fork $ do forM [1..10] $ \count -> do let message = Text.pack . show $ localpart we let payload = Payload count (even count) (Text.pack $ show count)