From 3161404679e3c99af3d38e63f3318081d33a2634 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 13 Jun 2012 18:18:06 +0200 Subject: [PATCH 1/3] clean up Types --- source/Network/Xmpp/Bind.hs | 2 +- source/Network/Xmpp/Types.hs | 39 ------------------------------------ 2 files changed, 1 insertion(+), 40 deletions(-) diff --git a/source/Network/Xmpp/Bind.hs b/source/Network/Xmpp/Bind.hs index cebec16..8963de5 100644 --- a/source/Network/Xmpp/Bind.hs +++ b/source/Network/Xmpp/Bind.hs @@ -35,7 +35,7 @@ xmppBind rsrc = do , Right jid <- unpickleElem jidP b -> return jid | otherwise -> throw $ StreamXMLError - "Bind could'nt unpickle JID" + "Bind couldn't unpickle JID" modify (\s -> s{sJid = Just jid}) return jid where diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index a407983..0dcd4ee 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -23,7 +23,6 @@ module Network.Xmpp.Types , SaslError(..) , SaslFailure(..) , SaslMechanism (..) - , SaslCredentials (..) , ServerFeatures(..) , Stanza(..) , StanzaError(..) @@ -253,31 +252,6 @@ instance Read PresenceType where readsPrec _ "probe" = [(Probe, "")] readsPrec _ _ = [] ---data ShowType = Available --- | Away --- | FreeChat --- | DND --- | XAway --- deriving Eq --- ---instance Show ShowType where --- show Available = "" --- show Away = "away" --- show FreeChat = "chat" --- show DND = "dnd" --- show XAway = "xa" --- ---instance Read ShowType where --- readsPrec _ "" = [( Available ,"")] --- readsPrec _ "available" = [( Available ,"")] --- readsPrec _ "away" = [( Away ,"")] --- readsPrec _ "chat" = [( FreeChat ,"")] --- readsPrec _ "dnd" = [( DND ,"")] --- readsPrec _ "xa" = [( XAway ,"")] --- readsPrec _ "invisible" = [( Available ,"")] --- readsPrec _ _ = [] - - -- | All stanzas (IQ, message, presence) can cause errors, which in the Xmpp -- stream looks like . These errors are -- wrapped in the @StanzaError@ type. @@ -402,17 +376,6 @@ instance Read StanzaErrorCondition where -- OTHER STUFF -- ============================================================================= -data SaslCredentials = DigestMD5Credentials (Maybe Text) Text Text - | PlainCredentials (Maybe Text) Text Text - -instance Show SaslCredentials where - show (DigestMD5Credentials authzid authcid _) = "DIGEST_MD5Credentials " ++ - (Text.unpack $ fromMaybe "" authzid) ++ " " ++ (Text.unpack authcid) ++ - " (password hidden)" - show (PlainCredentials authzid authcid _) = "PLAINCredentials " ++ - (Text.unpack $ fromMaybe "" authzid) ++ " " ++ (Text.unpack authcid) ++ - " (password hidden)" - data SaslMechanism = DigestMD5 deriving Show data SaslFailure = SaslFailure { saslFailureCondition :: SaslError @@ -476,8 +439,6 @@ instance Read SaslError where readsPrec _ "temporary-auth-failure" = [(SaslTemporaryAuthFailure , "")] readsPrec _ _ = [] --- data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq) - -- TODO: document the error cases data StreamErrorCondition = StreamBadFormat From 2c797c8bca96d03a74e5db349af3576f7e6c83bc Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 13 Jun 2012 18:17:13 +0200 Subject: [PATCH 2/3] remove sessionEndHandler --- source/Network/Xmpp.hs | 1 - source/Network/Xmpp/Concurrent/Monad.hs | 7 ------- source/Network/Xmpp/Concurrent/Threads.hs | 3 +-- source/Network/Xmpp/Concurrent/Types.hs | 3 +-- 4 files changed, 2 insertions(+), 12 deletions(-) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index e651f32..ee93fe3 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -37,7 +37,6 @@ module Network.Xmpp , startTLS , auth , endSession - , setSessionEndHandler , setConnectionClosedHandler -- * JID -- | A JID (historically: Jabber ID) is XMPPs native format diff --git a/source/Network/Xmpp/Concurrent/Monad.hs b/source/Network/Xmpp/Concurrent/Monad.hs index e879ecb..0d6102c 100644 --- a/source/Network/Xmpp/Concurrent/Monad.hs +++ b/source/Network/Xmpp/Concurrent/Monad.hs @@ -224,12 +224,6 @@ modifyHandlers f = do eh <- asks eventHandlers liftIO . atomically $ writeTVar eh . f =<< readTVar eh --- | Sets the handler to be executed when the session ends. -setSessionEndHandler :: Xmpp () -> Xmpp () -setSessionEndHandler eh = do - r <- ask - modifyHandlers (\s -> s{sessionEndHandler = runReaderT eh r}) - -- | Sets the handler to be executed when the server connection is closed. setConnectionClosedHandler :: (StreamError -> Xmpp ()) -> Xmpp () setConnectionClosedHandler eh = do @@ -247,7 +241,6 @@ endSession :: Xmpp () endSession = do -- TODO: This has to be idempotent (is it?) void $ withConnection xmppKillConnection liftIO =<< asks stopThreads - runHandler sessionEndHandler -- | Close the connection to the server. closeConnection :: Xmpp () diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs index 5d81db3..3dba714 100644 --- a/source/Network/Xmpp/Concurrent/Threads.hs +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -189,8 +189,7 @@ startThreads = do return () zeroEventHandlers :: EventHandlers zeroEventHandlers = EventHandlers - { sessionEndHandler = return () - , connectionClosedHandler = \_ -> return () + { connectionClosedHandler = \_ -> return () } -- | Creates and initializes a new Xmpp session. diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index e299dc4..6772df1 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -25,8 +25,7 @@ type IQHandlers = (Map.Map (IQRequestType, Text) (TChan IQRequestTicket) -- Handlers to be run when the Xmpp session ends and when the Xmpp connection is -- closed. data EventHandlers = EventHandlers - { sessionEndHandler :: IO () - , connectionClosedHandler :: StreamError -> IO () + { connectionClosedHandler :: StreamError -> IO () } -- The Session object is the Xmpp (ReaderT) state. From 4e24d6f16a2865e58b2b8d4f8315d8c5cec74cbc Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 13 Jun 2012 18:18:06 +0200 Subject: [PATCH 3/3] do proper disconnects --- source/Network/Xmpp.hs | 1 + source/Network/Xmpp/Bind.hs | 9 +++++---- source/Network/Xmpp/Concurrent/Monad.hs | 13 ++++++++++++- source/Network/Xmpp/Concurrent/Threads.hs | 17 ++++++++++++----- source/Network/Xmpp/Marshal.hs | 2 +- source/Network/Xmpp/Monad.hs | 13 +++++++++---- source/Network/Xmpp/Types.hs | 1 + source/Text/XML/Stream/Elements.hs | 22 +++++++++++++++++----- tests/Tests.hs | 14 ++++++++------ 9 files changed, 66 insertions(+), 26 deletions(-) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 4da49ce..abaad61 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -37,6 +37,7 @@ module Network.Xmpp , startTLS , simpleAuth , auth + , closeConnection , endSession , setConnectionClosedHandler -- * JID diff --git a/source/Network/Xmpp/Bind.hs b/source/Network/Xmpp/Bind.hs index 8963de5..5f9d45e 100644 --- a/source/Network/Xmpp/Bind.hs +++ b/source/Network/Xmpp/Bind.hs @@ -32,16 +32,17 @@ xmppBind :: Maybe Text -> XmppConMonad Jid xmppBind rsrc = do answer <- xmppSendIQ' "bind" Nothing Set Nothing (bindBody rsrc) jid <- case () of () | Right IQResult{iqResultPayload = Just b} <- answer - , Right jid <- unpickleElem jidP b + , Right jid <- unpickleElem xpJid b -> return jid | otherwise -> throw $ StreamXMLError - "Bind couldn't unpickle JID" + ("Bind couldn't unpickle JID from " ++ show answer) modify (\s -> s{sJid = Just jid}) return jid where -- Extracts the character data in the `jid' element. - jidP :: PU [Node] Jid - jidP = xpBind $ xpElemNodes "jid" (xpContent xpPrim) + xpJid :: PU [Node] Jid + xpJid = xpBind $ xpElemNodes jidName (xpContent xpPrim) + jidName = "{urn:ietf:params:xml:ns:xmpp-bind}jid" -- A `bind' element pickler. xpBind :: PU [Node] b -> PU [Node] b diff --git a/source/Network/Xmpp/Concurrent/Monad.hs b/source/Network/Xmpp/Concurrent/Monad.hs index 0d6102c..2cd7652 100644 --- a/source/Network/Xmpp/Concurrent/Monad.hs +++ b/source/Network/Xmpp/Concurrent/Monad.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} module Network.Xmpp.Concurrent.Monad where import Network.Xmpp.Types +import Control.Applicative((<$>)) import Control.Concurrent import Control.Concurrent.STM import qualified Control.Exception.Lifted as Ex @@ -244,4 +246,13 @@ endSession = do -- TODO: This has to be idempotent (is it?) -- | Close the connection to the server. closeConnection :: Xmpp () -closeConnection = void $ withConnection xmppKillConnection +closeConnection = Ex.mask_ $ do + write <- asks writeRef + send <- liftIO . atomically $ takeTMVar write + cc <- sCloseConnection <$> (liftIO . atomically . readTMVar =<< asks conStateRef) + liftIO . send $ "" + void . liftIO . forkIO $ do + threadDelay 3000000 + (Ex.try cc) :: IO (Either Ex.SomeException ()) + return () + liftIO . atomically $ putTMVar write (\_ -> return False) diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs index 3dba714..aa1a47a 100644 --- a/source/Network/Xmpp/Concurrent/Threads.hs +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -54,7 +54,10 @@ readWorker messageC presenceC stanzaC iqHands handlers stateRef = [ Ex.Handler $ \(Interrupt t) -> do void $ handleInterrupts [t] return Nothing - , Ex.Handler $ \(e :: StreamError) -> noCon handlers e + , Ex.Handler $ \(e :: StreamError) -> do + hands <- atomically $ readTVar handlers + _ <- forkIO $ connectionClosedHandler hands e + return Nothing ] liftIO . atomically $ do case res of @@ -139,10 +142,14 @@ writeWorker stCh writeR = forever $ do takeTMVar writeR <*> readTChan stCh r <- write $ renderElement (pickleElem xpStanza next) - unless r $ do -- If the writing failed, the connection is dead. - atomically $ unGetTChan stCh next + atomically $ putTMVar writeR write + unless r $ do + atomically $ unGetTChan stCh next -- If the writing failed, the + -- connection is dead. threadDelay 250000 -- Avoid free spinning. - atomically $ putTMVar writeR write -- Put it back. + + + -- Two streams: input and output. Threads read from input stream and write to -- output stream. @@ -236,4 +243,4 @@ connPersist lock = forever $ do pushBS <- atomically $ takeTMVar lock _ <- pushBS " " atomically $ putTMVar lock pushBS - threadDelay 30000000 + threadDelay 30000000 -- 30s diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs index 481ad78..d7e0ae8 100644 --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -206,4 +206,4 @@ xpStreamError = xpWrap ) (xpOption xpElemVerbatim) -- Application specific error conditions ) - ) \ No newline at end of file + ) diff --git a/source/Network/Xmpp/Monad.hs b/source/Network/Xmpp/Monad.hs index f7062f9..0f7d078 100644 --- a/source/Network/Xmpp/Monad.hs +++ b/source/Network/Xmpp/Monad.hs @@ -64,13 +64,16 @@ pullToSink snk = do pullElement :: XmppConMonad Element pullElement = do - Ex.catch (do + Ex.catches (do e <- pullToSink (elements =$ CL.head) case e of Nothing -> liftIO $ Ex.throwIO StreamConnectionError Just r -> return r ) - (\(InvalidEventStream s) -> liftIO . Ex.throwIO $ StreamXMLError s) + [ Ex.Handler (\StreamEnd -> Ex.throwIO StreamStreamEnd) + , Ex.Handler (\(InvalidEventStream s) + -> liftIO . Ex.throwIO $ StreamXMLError s) + ] -- Pulls an element and unpickles it. pullPickle :: PU [Node] a -> XmppConMonad a @@ -95,6 +98,7 @@ catchPush p = Ex.catch (p >> return True) (\e -> case GIE.ioe_type e of GIE.ResourceVanished -> return False + GIE.IllegalOperation -> return False _ -> Ex.throwIO e ) @@ -143,11 +147,12 @@ xmppNewSession :: XmppConMonad a -> IO (a, XmppConnection) xmppNewSession action = runStateT action xmppNoConnection -- Closes the connection and updates the XmppConMonad XmppConnection state. -xmppKillConnection :: XmppConMonad () +xmppKillConnection :: XmppConMonad (Either Ex.SomeException ()) xmppKillConnection = do cc <- gets sCloseConnection - void . liftIO $ (Ex.try cc :: IO (Either Ex.SomeException ())) + err <- liftIO $ (Ex.try cc :: IO (Either Ex.SomeException ())) put xmppNoConnection + return err -- Sends an IQ request and waits for the response. If the response ID does not -- match the outgoing ID, an error is thrown. diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 0dcd4ee..ce892f1 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -533,6 +533,7 @@ data XmppStreamError = XmppStreamError data StreamError = StreamError XmppStreamError | StreamWrongVersion Text | StreamXMLError String -- If stream pickling goes wrong. + | StreamStreamEnd -- received closing stream tag | StreamConnectionError deriving (Show, Eq, Typeable) diff --git a/source/Text/XML/Stream/Elements.hs b/source/Text/XML/Stream/Elements.hs index 72cf910..740a2f6 100644 --- a/source/Text/XML/Stream/Elements.hs +++ b/source/Text/XML/Stream/Elements.hs @@ -1,22 +1,26 @@ {-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} module Text.XML.Stream.Elements where import Control.Applicative ((<$>)) +import Control.Exception import Control.Monad.Trans.Class import Control.Monad.Trans.Resource as R import qualified Data.ByteString as BS +import Data.Conduit as C +import Data.Conduit.List as CL import qualified Data.Text as Text import qualified Data.Text.Encoding as Text +import Data.Typeable import Data.XML.Types -import qualified Text.XML.Stream.Render as TXSR -import Text.XML.Unresolved as TXU - -import Data.Conduit as C -import Data.Conduit.List as CL import System.IO.Unsafe(unsafePerformIO) +import qualified Text.XML.Stream.Render as TXSR +import Text.XML.Unresolved as TXU + compressNodes :: [Node] -> [Node] compressNodes [] = [] compressNodes [x] = [x] @@ -24,6 +28,13 @@ compressNodes (NodeContent (ContentText x) : NodeContent (ContentText y) : z) = compressNodes $ NodeContent (ContentText $ x `Text.append` y) : z compressNodes (x:xs) = x : compressNodes xs +streamName :: Name +streamName = + (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) + +data StreamEnd = StreamEnd deriving (Typeable, Show) +instance Exception StreamEnd + elements :: R.MonadThrow m => C.Conduit Event m Element elements = do x <- C.await @@ -31,6 +42,7 @@ elements = do Just (EventBeginElement n as) -> do goE n as >>= C.yield elements + Just (EventEndElement streamName) -> lift $ R.monadThrow StreamEnd Nothing -> return () _ -> lift $ R.monadThrow $ InvalidEventStream $ "not an element: " ++ show x where diff --git a/tests/Tests.hs b/tests/Tests.hs index 7f5b3c1..de3d4bb 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -3,6 +3,7 @@ module Example where import Control.Concurrent import Control.Concurrent.STM +import qualified Control.Exception.Lifted as Ex import Control.Monad import Control.Monad.IO.Class @@ -17,7 +18,7 @@ import Network.Xmpp.IM.Presence import Network.Xmpp.Pickle import System.Environment -import Text.XML.Stream.Elements +import Text.XML.Stream.Elements testUser1 :: Jid testUser1 = read "testuser1@species64739.dyndns.org/bot1" @@ -114,19 +115,20 @@ runMain debug number = do debug . (("Thread " ++ show number ++ ":") ++) wait <- newEmptyTMVarIO withNewSession $ do - setSessionEndHandler (liftIO . atomically $ putTMVar wait ()) setConnectionClosedHandler (\e -> do liftIO (debug' $ "connection lost because " ++ show e) endSession ) debug' "running" - withConnection $ do + withConnection $ Ex.catch (do connect "localhost" "species64739.dyndns.org" startTLS exampleParams - saslResponse <- auth (fromJust $ localpart we) "pwd" (resourcepart we) + saslResponse <- simpleAuth + (fromJust $ localpart we) "pwd" (resourcepart we) case saslResponse of Right _ -> return () Left e -> error $ show e - debug' "session standing" + debug' "session standing") + (\e -> liftIO (print (e ::Ex.SomeException) >> Ex.throwIO e) ) sendPresence presenceOnline fork autoAccept sendPresence $ presenceSubscribe them @@ -148,7 +150,7 @@ runMain debug number = do sendUser "All tests done" debug' "ending session" liftIO . atomically $ putTMVar wait () - endSession + closeConnection liftIO . atomically $ takeTMVar wait return () return ()