reinstate withConnection and fix closeConnection

source/Network/Xmpp/Concurrent/Monad.hs

@@ -2,61 +2,63 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Network.Xmpp.Concurrent.Monad where
 
-import           Network.Xmpp.Types
+import           Control.Concurrent
-
 import           Control.Concurrent.STM
 import qualified Control.Exception.Lifted as Ex
 import           Control.Monad.Reader
-
+import           Control.Monad.State
 import           Network.Xmpp.Concurrent.Types
 import           Network.Xmpp.Stream
-
+import           Network.Xmpp.Types
-
 
 
 -- TODO: Wait for presence error?
 
--- -- | Run an XmppConMonad action in isolation. Reader and writer workers will be
+-- | Run an XmppConMonad action in isolation. Reader and writer workers will be
--- -- temporarily stopped and resumed with the new session details once the action
+-- temporarily stopped and resumed with the new session details once the action
--- -- returns. The action will run in the calling thread. Any uncaught exceptions
+-- returns. The action will run in the calling thread. Any uncaught exceptions
--- -- will be interpreted as connection failure.
+-- will be interpreted as connection failure.
 -- withConnection :: XmppConMonad a -> Context -> IO (Either StreamError a)
--- withConnection a session =  do
+withConnection :: (Stream -> IO (b, Stream))
---     wait <- newEmptyTMVarIO
+               -> Session
---     Ex.mask_ $ do
+               -> IO (Either XmppFailure b)
---         -- Suspends the reader until the lock (wait) is released (set to `()').
+withConnection a session =  do
---         throwTo (readerThread session) $ Interrupt wait
+    wait <- newEmptyTMVarIO
---         -- We acquire the write and stateRef locks, to make sure that this is
+    Ex.mask_ $ do
---         -- the only thread that can write to the stream and to perform a
+        -- Suspends the reader until the lock (wait) is released (set to `()').
---         -- withConnection calculation. Afterwards, we release the lock and
+        throwTo (readerThread session) $ Interrupt wait
---         -- fetches an updated state.
+        -- We acquire the write and stateRef locks, to make sure that this is
---         s <- Ex.catch
+        -- the only thread that can write to the stream and to perform a
---             (atomically $ do
+        -- withConnection calculation. Afterwards, we release the lock and
---                  _ <- takeTMVar  (writeRef session)
+        -- fetches an updated state.
---                  s <- takeTMVar (conStateRef session)
+        s <- Ex.catch
---                  putTMVar wait ()
+            (atomically $ do
---                  return s
+                 _ <- takeTMVar (writeRef session)
---             )
+                 s <- takeTMVar (streamRef session)
---             -- If we catch an exception, we have failed to take the MVars above.
+                 putTMVar wait ()
---             (\e -> atomically (putTMVar wait ()) >>
+                 return s
---                  Ex.throwIO (e :: Ex.SomeException)
+            )
---             )
+            -- If we catch an exception, we have failed to take the MVars above.
---         -- Run the XmppMonad action, save the (possibly updated) states, release
+            (\e -> atomically (putTMVar wait ()) >>
---         -- the locks, and return the result.
+                 Ex.throwIO (e :: Ex.SomeException)
---         Ex.catches
+            )
---             (do
+        -- Run the XmppMonad action, save the (possibly updated) states, release
---                  (res, s') <- runStateT a s
+        -- the locks, and return the result.
---                  atomically $ do
+        Ex.catches
---                      putTMVar (writeRef session) (cSend . sCon $ s')
+            (do
---                      putTMVar (conStateRef session) s'
+                 (res, s') <- a s
---                      return $ Right res
+                 wl <- withStream' (gets $ streamSend . streamHandle) s'
---             )
+                 atomically $ do
---             -- We treat all Exceptions as fatal. If we catch a StreamError, we
+                     putTMVar (writeRef session) wl
---             -- return it. Otherwise, we throw an exception.
+                     putTMVar (streamRef session) s'
---             [ Ex.Handler $ \e -> return $ Left (e :: StreamError)
+                     return $ Right res
---             , Ex.Handler $ \e -> runStateT xmppKillConnection s
+            )
---                   >> Ex.throwIO (e :: Ex.SomeException)
+            -- We treat all Exceptions as fatal. If we catch a StreamError, we
---             ]
+            -- return it. Otherwise, we throw an exception.
+            [ Ex.Handler $ \e -> return $ Left (e :: XmppFailure)
+            , Ex.Handler $ \e -> killStream s
+                  >> Ex.throwIO (e :: Ex.SomeException)
+            ]
 
 -- | Executes a function to update the event handlers.
 modifyHandlers :: (EventHandlers -> EventHandlers) -> Session -> IO ()
@@ -86,16 +88,13 @@ runHandler h session = h =<< atomically (readTVar $ eventHandlers session)
 -- | End the current Xmpp session.
 endSession :: Session -> IO ()
 endSession session =  do -- TODO: This has to be idempotent (is it?)
-    closeConnection session
+    _ <- closeConnection session
     stopThreads session
 
 -- | Close the connection to the server. Closes the stream (by enforcing a
 -- write lock and sending a </stream:stream> element), waits (blocks) for three
 -- seconds, and then closes the connection.
-closeConnection :: Session -> IO ()
+closeConnection :: Session -> IO (Either XmppFailure ())
-closeConnection session = Ex.mask_ $ do
+closeConnection = withConnection $ \stream -> do
-    (_send, connection) <- atomically $ liftM2 (,)
+    _ <- closeStreams stream
-                             (takeTMVar $ writeRef session)
+    return ((), stream)
-                             (takeTMVar $ streamRef session)
-    _ <- closeStreams connection
-    return ()