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

@@ -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
 

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

src/Network/XMPP.hs

@@ -84,8 +84,10 @@ module Network.XMPP
   -- <http://xmpp.org/rfcs/rfc6120.html#stanzas-semantics-message>
   , 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

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
+        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!

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)

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"

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
@@ -62,7 +63,7 @@ xmppStartStream = runErrorT $ do
 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
 

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.

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)