From 7d5007096e6a469d2c8207f2348d8f31efdb14b4 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Fri, 23 Aug 2013 17:43:54 +0200 Subject: [PATCH] clean up some minor problems --- source/Network/Xmpp.hs | 1 + source/Network/Xmpp/Concurrent.hs | 4 +- source/Network/Xmpp/Concurrent/Basic.hs | 1 + source/Network/Xmpp/Concurrent/Monad.hs | 8 +++- tests/Tests.hs | 55 ++++++++++++++----------- 5 files changed, 42 insertions(+), 27 deletions(-) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index e4863d2..4cd8df3 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -36,6 +36,7 @@ module Network.Xmpp , ConnectionDetails(..) , closeConnection , endSession + , waitForStream -- TODO: Close session, etc. -- ** Authentication handlers -- | The use of 'scramSha1' is /recommended/, but 'digestMd5' might be diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 98ed1f7..73fb733 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -269,9 +269,9 @@ reconnect' sess = go 0 res <- doRetry sess case res of Nothing -> return i - Just e -> go (i+1) - + Just _e -> go (i+1) +doRetry :: Session -> IO (Maybe XmppFailure) doRetry sess@Session{reconnectWait = rw} = do wait <- atomically $ do wt <- readTVar rw diff --git a/source/Network/Xmpp/Concurrent/Basic.hs b/source/Network/Xmpp/Concurrent/Basic.hs index 8c48559..7de23f7 100644 --- a/source/Network/Xmpp/Concurrent/Basic.hs +++ b/source/Network/Xmpp/Concurrent/Basic.hs @@ -52,6 +52,7 @@ getFeatures Session{streamRef = st} = do s <- atomically $ readTMVar st withStream' (gets streamFeatures) s +-- | Wait until the connection of the stream is re-established waitForStream :: Session -> IO () waitForStream Session{streamRef = sr} = atomically $ do s <- readTMVar sr diff --git a/source/Network/Xmpp/Concurrent/Monad.hs b/source/Network/Xmpp/Concurrent/Monad.hs index 0aeb4c1..98782f2 100644 --- a/source/Network/Xmpp/Concurrent/Monad.hs +++ b/source/Network/Xmpp/Concurrent/Monad.hs @@ -91,12 +91,18 @@ runHandler h session = h =<< atomically (readTMVar $ eventHandlers session) -- | End the current Xmpp session. +-- Kills the associated threads and closes the connection. +-- +-- The connectionClosedHandler will not be called (to avoid possibly +-- reestablishing the connection) endSession :: Session -> IO () endSession session = do -- TODO: This has to be idempotent (is it?) + stopThreads session _ <- flip withConnection session $ \stream -> do _ <- closeStreams stream return ((), stream) - stopThreads session + return () + -- | Close the connection to the server. Closes the stream (by enforcing a -- write lock and sending a element), waits (blocks) for three diff --git a/tests/Tests.hs b/tests/Tests.hs index 8614b70..4ef2e2f 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE QuasiQuotes #-} module Example where import Control.Concurrent @@ -21,6 +23,7 @@ import Network.Xmpp.IM.Presence import Network.Xmpp.Internal import Network.Xmpp.Marshal import Network.Xmpp.Types +import Network.Xmpp.Utilities (renderElement) -- import qualified Network.Xmpp.Xep.InbandRegistration as IBR import Data.Default (def) import qualified Network.Xmpp.Xep.ServiceDiscovery as Disco @@ -28,13 +31,13 @@ import System.Environment import System.Log.Logger testUser1 :: Jid -testUser1 = parseJid "echo1@species64739.dyndns.org/bot" +testUser1 = [jidQ|echo1@species64739.dyndns.org/bot|] testUser2 :: Jid -testUser2 = parseJid "echo2@species64739.dyndns.org/bot" +testUser2 = [jidQ|echo2@species64739.dyndns.org/bot|] supervisor :: Jid -supervisor = parseJid "uart14@species64739.dyndns.org" +supervisor = [jidQ|uart14@species64739.dyndns.org|] config = def{sessionStreamConfiguration = def{connectionDetails = UseHost "localhost" (PortNumber 5222)}} @@ -117,23 +120,23 @@ expect debug x y context | x == y = debug "Ok." wait3 :: MonadIO m => m () wait3 = liftIO $ threadDelay 1000000 --- discoTest debug context = do --- q <- Disco.queryInfo "species64739.dyndns.org" Nothing context --- case q of --- Left (Disco.DiscoXMLError el e) -> do --- debug (ppElement el) --- debug (Text.unpack $ ppUnpickleError e) --- debug (show $ length $ elementNodes el) --- x -> debug $ show x - --- q <- Disco.queryItems "species64739.dyndns.org" --- (Just "http://jabber.org/protocol/commands") context --- case q of --- Left (Disco.DiscoXMLError el e) -> do --- debug (ppElement el) --- debug (Text.unpack $ ppUnpickleError e) --- debug (show $ length $ elementNodes el) --- x -> debug $ show x +discoTest debug context = do + q <- Disco.queryInfo [jidQ|species64739.dyndns.org|] Nothing context + case q of + Left (Disco.DiscoXmlError el e) -> do + debug (show $ renderElement el) + debug (ppUnpickleError e) + debug (show $ length $ elementNodes el) + x -> debug $ show x + + q <- Disco.queryItems [jidQ|species64739.dyndns.org|] + (Just "http://jabber.org/protocol/commands") context + case q of + Left (Disco.DiscoXmlError el e) -> do + debug (show $ renderElement el) + debug (ppUnpickleError e) + debug (show $ length $ elementNodes el) + x -> debug $ show x iqTest debug we them context = do forM [1..10] $ \count -> do @@ -178,7 +181,7 @@ runMain debug number multi = do thread2 <- forkIO $ iqResponder =<< dupSession context when active $ do liftIO $ threadDelay 1000000 -- Wait for the other thread to go online --- discoTest debug' + discoTest debug' context -- when multi $ iqTest debug' we them context killThread thread1 killThread thread2 @@ -198,7 +201,7 @@ run i multi = do main = do updateGlobalLogger "Pontarius.Xmpp" $ setLevel DEBUG - run 0 True + run 1 False connectionClosedTest = do @@ -209,10 +212,14 @@ connectionClosedTest = do Right context <- session (Text.unpack $ domainpart we) (Just (\_ -> [scramSha1 (fromJust $ localpart we) Nothing "pwd"], resourcepart we)) config {onConnectionClosed = \s e -> do - liftIO $ reconnect Nothing s + liftIO $ reconnect' s liftIO $ sendPresence presenceOnline s return () } sendPresence presenceOnline context + forkIO $ do + threadDelay 1000000 + endSession context + debug' "done" forever $ threadDelay 1000000 return ()