clean up some minor problems

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

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

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

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 </stream:stream> element), waits (blocks) for three

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 ()