asakul
/
pontarius-xmpp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

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
master
Philipp Balzarek 14 years ago
parent
f3d1a37146
commit
b4b2610880
9 changed files with 105 additions and 85 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 1
      pontarius.cabal
  2. 20
      src/Data/Conduit/BufferedSource.hs
  3. 6
      src/Network/XMPP.hs
  4. 21
      src/Network/XMPP/Concurrent/Threads.hs
  5. 6
      src/Network/XMPP/Monad.hs
  6. 39
      src/Network/XMPP/SASL.hs
  7. 5
      src/Network/XMPP/Stream.hs
  8. 78
      src/Network/XMPP/Types.hs
  9. 14
      src/Tests.hs

1
pontarius.cabal
Unescape View File

@ -69,6 +69,7 @@ Library
, Network.XMPP.Concurrent.Threads , Network.XMPP.Concurrent.Threads
, Network.XMPP.Concurrent.Monad , Network.XMPP.Concurrent.Monad
, Text.XML.Stream.Elements , Text.XML.Stream.Elements
, Data.Conduit.BufferedSource
, Data.Conduit.TLS , Data.Conduit.TLS
GHC-Options: -Wall GHC-Options: -Wall

20
src/Data/Conduit/BufferedSource.hs
Unescape View File

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

6
src/Network/XMPP.hs
Unescape View File

@ -84,8 +84,10 @@ module Network.XMPP
-- <http://xmpp.org/rfcs/rfc6120.html#stanzas-semantics-message> -- <http://xmpp.org/rfcs/rfc6120.html#stanzas-semantics-message>
, Message , Message
, MessageError , MessageError
, MessageType(..)
-- *** creating -- *** creating
, module Network.XMPP.Message , simpleMessage
, answerMessage
-- *** sending -- *** sending
, sendMessage , sendMessage
-- *** receiving -- *** receiving
@ -174,7 +176,7 @@ auth :: Text.Text -- ^ The username
-> Text.Text -- ^ The password -> Text.Text -- ^ The password
-> Maybe Text -- ^ The desired resource or 'Nothing' to let the server -> Maybe Text -- ^ The desired resource or 'Nothing' to let the server
-- assign one -- assign one
-> XMPP (Either SaslError Text.Text) -> XMPP (Either AuthError Text.Text)
auth username passwd resource = runErrorT $ do auth username passwd resource = runErrorT $ do
ErrorT . withConnection $ xmppSASL username passwd ErrorT . withConnection $ xmppSASL username passwd
res <- lift $ xmppBind resource res <- lift $ xmppBind resource

21
src/Network/XMPP/Concurrent/Threads.hs
Unescape View File

@ -44,17 +44,13 @@ readWorker :: TChan (Either MessageError Message)
-> IO () -> IO ()
readWorker messageC presenceC handlers stateRef = readWorker messageC presenceC handlers stateRef =
Ex.mask_ . forever $ do Ex.mask_ . forever $ do
res <- liftIO $ Ex.catch ( res <- liftIO $ Ex.catch ( do
Ex.bracket -- we don't know whether pull will
(atomically $ takeTMVar stateRef) -- necessarily be interruptible
(atomically . putTMVar stateRef ) s <- liftIO . atomically $ readTMVar stateRef
(\s -> do allowInterrupt
-- we don't know whether pull will Just <$> runStateT pullStanza s
-- necessarily be interruptible )
allowInterrupt
Just <$> runStateT pullStanza s
)
)
(\(Interrupt t) -> do (\(Interrupt t) -> do
void $ handleInterrupts [t] void $ handleInterrupts [t]
return Nothing return Nothing
@ -62,8 +58,7 @@ readWorker messageC presenceC handlers stateRef =
liftIO . atomically $ do liftIO . atomically $ do
case res of case res of
Nothing -> return () Nothing -> return ()
Just (sta, s') -> do Just (sta, _s) -> do
putTMVar stateRef s'
case sta of case sta of
MessageS m -> do writeTChan messageC $ Right m MessageS m -> do writeTChan messageC $ Right m
_ <- readTChan messageC -- Sic! _ <- readTChan messageC -- Sic!

6
src/Network/XMPP/Monad.hs
Unescape View File

@ -13,6 +13,7 @@ import Control.Monad.State.Strict
import Data.ByteString as BS import Data.ByteString as BS
import Data.Conduit import Data.Conduit
import Data.Conduit.BufferedSource
import Data.Conduit.Binary as CB import Data.Conduit.Binary as CB
import Data.Text(Text) import Data.Text(Text)
import Data.XML.Pickle import Data.XML.Pickle
@ -45,8 +46,7 @@ pushOpen e = do
pullSink :: Sink Event IO b -> XMPPConMonad b pullSink :: Sink Event IO b -> XMPPConMonad b
pullSink snk = do pullSink snk = do
source <- gets sConSrc source <- gets sConSrc
(src', r) <- lift $ source $$+ snk (_, r) <- lift $ source $$+ snk
modify $ (\s -> s {sConSrc = src'})
return r return r
pullElement :: XMPPConMonad Element pullElement :: XMPPConMonad Element
@ -114,7 +114,7 @@ xmppRawConnect host hostname = do
hSetBuffering con NoBuffering hSetBuffering con NoBuffering
return con return con
let raw = sourceHandle con let raw = sourceHandle con
let src = raw $= XP.parseBytes def src <- liftIO . bufferSource $ raw $= XP.parseBytes def
let st = XMPPConState let st = XMPPConState
src src
(raw) (raw)

39
src/Network/XMPP/SASL.hs
Unescape View File

@ -51,16 +51,17 @@ saslResponse2E =
[] []
[] []
data SaslError = SaslXmlError data AuthError = AuthXmlError
| SaslMechanismError [Text] | AuthMechanismError [Text]
| SaslChallengeError | AuthChallengeError
| SaslStreamError StreamError | AuthStreamError StreamError
| SaslConnectionError | AuthConnectionError
deriving Show
instance Error SaslError where instance Error AuthError where
noMsg = SaslXmlError noMsg = AuthXmlError
xmppSASL:: Text -> Text -> XMPPConMonad (Either SaslError Text) xmppSASL:: Text -> Text -> XMPPConMonad (Either AuthError Text)
xmppSASL uname passwd = runErrorT $ do xmppSASL uname passwd = runErrorT $ do
realm <- gets sHostname realm <- gets sHostname
case realm of case realm of
@ -68,37 +69,37 @@ xmppSASL uname passwd = runErrorT $ do
ErrorT $ xmppStartSASL realm' uname passwd ErrorT $ xmppStartSASL realm' uname passwd
modify (\s -> s{sUsername = Just uname}) modify (\s -> s{sUsername = Just uname})
return uname return uname
Nothing -> throwError SaslConnectionError Nothing -> throwError AuthConnectionError
xmppStartSASL :: Text xmppStartSASL :: Text
-> Text -> Text
-> Text -> Text
-> XMPPConMonad (Either SaslError ()) -> XMPPConMonad (Either AuthError ())
xmppStartSASL realm username passwd = runErrorT $ do xmppStartSASL realm username passwd = runErrorT $ do
mechanisms <- gets $ saslMechanisms . sFeatures mechanisms <- gets $ saslMechanisms . sFeatures
unless ("DIGEST-MD5" `elem` mechanisms) unless ("DIGEST-MD5" `elem` mechanisms)
. throwError $ SaslMechanismError mechanisms . throwError $ AuthMechanismError mechanisms
lift . pushN $ saslInitE "DIGEST-MD5" lift . pushN $ saslInitE "DIGEST-MD5"
challenge' <- lift $ B64.decode . Text.encodeUtf8 challenge' <- lift $ B64.decode . Text.encodeUtf8
<$> pullPickle challengePickle <$> pullPickle challengePickle
challenge <- case challenge' of challenge <- case challenge' of
Left _e -> throwError SaslChallengeError Left _e -> throwError AuthChallengeError
Right r -> return r Right r -> return r
pairs <- case toPairs challenge of pairs <- case toPairs challenge of
Left _ -> throwError SaslChallengeError Left _ -> throwError AuthChallengeError
Right p -> return p Right p -> return p
g <- liftIO $ Random.newStdGen g <- liftIO $ Random.newStdGen
lift . pushN . saslResponseE $ createResponse g realm username passwd pairs lift . pushN . saslResponseE $ createResponse g realm username passwd pairs
challenge2 <- lift $ pullPickle (xpEither failurePickle challengePickle) challenge2 <- lift $ pullPickle (xpEither failurePickle challengePickle)
case challenge2 of case challenge2 of
Left _x -> throwError $ SaslXmlError Left _x -> throwError $ AuthXmlError
Right _ -> return () Right _ -> return ()
lift $ pushN saslResponse2E lift $ pushN saslResponse2E
e <- lift pullElement e <- lift pullElement
case e of case e of
Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] -> return () Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] -> return ()
_ -> throwError SaslXmlError -- TODO: investigate _ -> throwError AuthXmlError -- TODO: investigate
_ <- ErrorT $ left SaslStreamError <$> xmppRestartStream _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream
return () return ()
createResponse :: Random.RandomGen g 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] in hash [ha1,nonce, nc, cnonce,qop,ha2]
-- Pickling -- Pickling
failurePickle :: PU [Node] (SASLFailure) failurePickle :: PU [Node] (SaslFailure)
failurePickle = xpWrap (\(txt,(failure,_,_)) failurePickle = xpWrap (\(txt,(failure,_,_))
-> SASLFailure failure txt) -> SaslFailure failure txt)
(\(SASLFailure failure txt) (\(SaslFailure failure txt)
-> (txt,(failure,(),()))) -> (txt,(failure,(),())))
(xpElemNodes (xpElemNodes
"{urn:ietf:params:xml:ns:xmpp-sasl}failure" "{urn:ietf:params:xml:ns:xmpp-sasl}failure"

5
src/Network/XMPP/Stream.hs
Unescape View File

@ -7,6 +7,7 @@ import Control.Monad.Error
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Data.Conduit import Data.Conduit
import Data.Conduit.BufferedSource
import Data.Conduit.List as CL import Data.Conduit.List as CL
import Data.Text as T import Data.Text as T
import Data.XML.Pickle import Data.XML.Pickle
@ -55,14 +56,14 @@ xmppStartStream = runErrorT $ do
Nothing -> throwError StreamConnectionError Nothing -> throwError StreamConnectionError
Just hostname -> lift . pushOpen $ Just hostname -> lift . pushOpen $
pickleElem pickleStream ("1.0",Nothing, Just hostname) pickleElem pickleStream ("1.0",Nothing, Just hostname)
features <- ErrorT . pullSink $ runErrorT xmppStream features <- ErrorT . pullSink $ runErrorT xmppStream
modify (\s -> s {sFeatures = features}) modify (\s -> s {sFeatures = features})
return () return ()
xmppRestartStream :: XMPPConMonad (Either StreamError ()) xmppRestartStream :: XMPPConMonad (Either StreamError ())
xmppRestartStream = do xmppRestartStream = do
raw <- gets sRawSrc raw <- gets sRawSrc
let newsrc = raw $= XP.parseBytes def newsrc <- liftIO . bufferSource $ raw $= XP.parseBytes def
modify (\s -> s{sConSrc = newsrc}) modify (\s -> s{sConSrc = newsrc})
xmppStartStream xmppStartStream

78
src/Network/XMPP/Types.hs
Unescape View File

@ -25,8 +25,8 @@ module Network.XMPP.Types
, Presence(..) , Presence(..)
, PresenceError(..) , PresenceError(..)
, PresenceType(..) , PresenceType(..)
, SASLError(..) , SaslError(..)
, SASLFailure(..) , SaslFailure(..)
, ServerAddress(..) , ServerAddress(..)
, ServerFeatures(..) , ServerFeatures(..)
, ShowType(..) , ShowType(..)
@ -468,67 +468,67 @@ instance Read StanzaErrorCondition where
-- OTHER STUFF -- OTHER STUFF
-- ============================================================================= -- =============================================================================
data SASLFailure = SASLFailure { saslFailureCondition :: SASLError data SaslFailure = SaslFailure { saslFailureCondition :: SaslError
, saslFailureText :: Maybe ( Maybe LangTag , saslFailureText :: Maybe ( Maybe LangTag
, Text , Text
) )
} deriving Show } deriving Show
data SASLError = SASLAborted -- ^ Client aborted data SaslError = SaslAborted -- ^ Client aborted
| SASLAccountDisabled -- ^ The account has been temporarily | SaslAccountDisabled -- ^ The account has been temporarily
-- disabled -- disabled
| SASLCredentialsExpired -- ^ The authentication failed because | SaslCredentialsExpired -- ^ The authentication failed because
-- the credentials have expired -- the credentials have expired
| SASLEncryptionRequired -- ^ The mechanism requested cannot be | SaslEncryptionRequired -- ^ The mechanism requested cannot be
-- used the confidentiality and -- used the confidentiality and
-- integrity of the underlying -- integrity of the underlying
-- stream is protected (typically -- stream is protected (typically
-- with TLS) -- with TLS)
| SASLIncorrectEncoding -- ^ The base64 encoding is incorrect | SaslIncorrectEncoding -- ^ The base64 encoding is incorrect
| SASLInvalidAuthzid -- ^ The authzid has an incorrect | SaslInvalidAuthzid -- ^ The authzid has an incorrect
-- format or the initiating entity does -- format or the initiating entity does
-- not have the appropriate permissions -- not have the appropriate permissions
-- to authorize that ID -- to authorize that ID
| SASLInvalidMechanism -- ^ The mechanism is not supported by | SaslInvalidMechanism -- ^ The mechanism is not supported by
-- the receiving entity -- the receiving entity
| SASLMalformedRequest -- ^ Invalid syntax | SaslMalformedRequest -- ^ Invalid syntax
| SASLMechanismTooWeak -- ^ The receiving entity policy | SaslMechanismTooWeak -- ^ The receiving entity policy
-- requires a stronger mechanism -- requires a stronger mechanism
| SASLNotAuthorized -- ^ Invalid credentials | SaslNotAuthorized -- ^ Invalid credentials
-- provided, or some -- provided, or some
-- generic authentication -- generic authentication
-- failure has occurred -- failure has occurred
| SASLTemporaryAuthFailure -- ^ There receiving entity reported a | SaslTemporaryAuthFailure -- ^ There receiving entity reported a
-- temporary error condition; the -- temporary error condition; the
-- initiating entity is recommended -- initiating entity is recommended
-- to try again later -- to try again later
instance Show SASLError where instance Show SaslError where
show SASLAborted = "aborted" show SaslAborted = "aborted"
show SASLAccountDisabled = "account-disabled" show SaslAccountDisabled = "account-disabled"
show SASLCredentialsExpired = "credentials-expired" show SaslCredentialsExpired = "credentials-expired"
show SASLEncryptionRequired = "encryption-required" show SaslEncryptionRequired = "encryption-required"
show SASLIncorrectEncoding = "incorrect-encoding" show SaslIncorrectEncoding = "incorrect-encoding"
show SASLInvalidAuthzid = "invalid-authzid" show SaslInvalidAuthzid = "invalid-authzid"
show SASLInvalidMechanism = "invalid-mechanism" show SaslInvalidMechanism = "invalid-mechanism"
show SASLMalformedRequest = "malformed-request" show SaslMalformedRequest = "malformed-request"
show SASLMechanismTooWeak = "mechanism-too-weak" show SaslMechanismTooWeak = "mechanism-too-weak"
show SASLNotAuthorized = "not-authorized" show SaslNotAuthorized = "not-authorized"
show SASLTemporaryAuthFailure = "temporary-auth-failure" show SaslTemporaryAuthFailure = "temporary-auth-failure"
instance Read SASLError where instance Read SaslError where
readsPrec _ "aborted" = [(SASLAborted , "")] readsPrec _ "aborted" = [(SaslAborted , "")]
readsPrec _ "account-disabled" = [(SASLAccountDisabled , "")] readsPrec _ "account-disabled" = [(SaslAccountDisabled , "")]
readsPrec _ "credentials-expired" = [(SASLCredentialsExpired , "")] readsPrec _ "credentials-expired" = [(SaslCredentialsExpired , "")]
readsPrec _ "encryption-required" = [(SASLEncryptionRequired , "")] readsPrec _ "encryption-required" = [(SaslEncryptionRequired , "")]
readsPrec _ "incorrect-encoding" = [(SASLIncorrectEncoding , "")] readsPrec _ "incorrect-encoding" = [(SaslIncorrectEncoding , "")]
readsPrec _ "invalid-authzid" = [(SASLInvalidAuthzid , "")] readsPrec _ "invalid-authzid" = [(SaslInvalidAuthzid , "")]
readsPrec _ "invalid-mechanism" = [(SASLInvalidMechanism , "")] readsPrec _ "invalid-mechanism" = [(SaslInvalidMechanism , "")]
readsPrec _ "malformed-request" = [(SASLMalformedRequest , "")] readsPrec _ "malformed-request" = [(SaslMalformedRequest , "")]
readsPrec _ "mechanism-too-weak" = [(SASLMechanismTooWeak , "")] readsPrec _ "mechanism-too-weak" = [(SaslMechanismTooWeak , "")]
readsPrec _ "not-authorized" = [(SASLNotAuthorized , "")] readsPrec _ "not-authorized" = [(SaslNotAuthorized , "")]
readsPrec _ "temporary-auth-failure" = [(SASLTemporaryAuthFailure , "")] readsPrec _ "temporary-auth-failure" = [(SaslTemporaryAuthFailure , "")]
readsPrec _ _ = [] readsPrec _ _ = []
-- | Readability type for host name Texts. -- | Readability type for host name Texts.

14
src/Tests.hs
Unescape View File

@ -28,7 +28,7 @@ supervisor :: JID
supervisor = read "uart14@species64739.dyndns.org" supervisor = read "uart14@species64739.dyndns.org"
attXmpp :: STM a -> XMPPThread a attXmpp :: STM a -> XMPP a
attXmpp = liftIO . atomically attXmpp = liftIO . atomically
testNS :: Text testNS :: Text
@ -66,7 +66,7 @@ iqResponder = do
answerIQ next (Right $ Just answerBody) answerIQ next (Right $ Just answerBody)
when (payloadCounter payload == 10) endSession when (payloadCounter payload == 10) endSession
autoAccept :: XMPPThread () autoAccept :: XMPP ()
autoAccept = forever $ do autoAccept = forever $ do
st <- waitForPresence isPresenceSubscribe st <- waitForPresence isPresenceSubscribe
sendPresence $ presenceSubscribed (fromJust $ presenceFrom st) sendPresence $ presenceSubscribed (fromJust $ presenceFrom st)
@ -92,7 +92,7 @@ runMain debug number = do
let debug' = liftIO . atomically . let debug' = liftIO . atomically .
debug . (("Thread " ++ show number ++ ":") ++) debug . (("Thread " ++ show number ++ ":") ++)
wait <- newEmptyTMVarIO wait <- newEmptyTMVarIO
xmppNewSession $ do withNewSession $ do
setSessionEndHandler (liftIO . atomically $ putTMVar wait ()) setSessionEndHandler (liftIO . atomically $ putTMVar wait ())
debug' "running" debug' "running"
connect "localhost" "species64739.dyndns.org" connect "localhost" "species64739.dyndns.org"
@ -100,15 +100,15 @@ runMain debug number = do
saslResponse <- auth (fromJust $ localpart we) "pwd" (resourcepart we) saslResponse <- auth (fromJust $ localpart we) "pwd" (resourcepart we)
case saslResponse of case saslResponse of
Right _ -> return () Right _ -> return ()
Left e -> error "saslerror" Left e -> error $ show e
debug' "session standing" debug' "session standing"
sendPresence presenceOnline sendPresence presenceOnline
forkXMPP autoAccept fork autoAccept
sendPresence $ presenceSubscribe them sendPresence $ presenceSubscribe them
forkXMPP iqResponder fork iqResponder
when active $ do when active $ do
liftIO $ threadDelay 1000000 -- Wait for the other thread to go online liftIO $ threadDelay 1000000 -- Wait for the other thread to go online
void . forkXMPP $ do void . fork $ do
forM [1..10] $ \count -> do forM [1..10] $ \count -> do
let message = Text.pack . show $ localpart we let message = Text.pack . show $ localpart we
let payload = Payload count (even count) (Text.pack $ show count) let payload = Payload count (even count) (Text.pack $ show count)

Write Preview
Loading…
Cancel
Save