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)