{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.Xmpp.Concurrent.Monad where

import           Control.Applicative ((<$>))
import           Control.Concurrent
import           Control.Concurrent.STM
import qualified Control.Exception.Lifted as Ex
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
-- temporarily stopped and resumed with the new session details once the action
-- returns. The action will run in the calling thread. Any uncaught exceptions
-- will be interpreted as connection failure.
-- withConnection :: XmppConMonad a -> Context -> IO (Either StreamError a)
withConnection :: (Stream -> IO (b, Stream))
               -> Session
               -> IO (Either XmppFailure b)
withConnection :: forall b.
(Stream -> IO (b, Stream)) -> Session -> IO (Either XmppFailure b)
withConnection Stream -> IO (b, Stream)
a Session
session =  do
    TMVar ()
wait <- forall a. IO (TMVar a)
newEmptyTMVarIO
    forall (m :: * -> *) a. MonadBaseControl IO m => m a -> m a
Ex.mask_ forall a b. (a -> b) -> a -> b
$ do
        -- Suspends the reader until the lock (wait) is released (set to `()').
        forall e. Exception e => ThreadId -> e -> IO ()
throwTo (Session -> ThreadId
readerThread Session
session) forall a b. (a -> b) -> a -> b
$ TMVar () -> Interrupt
Interrupt TMVar ()
wait
        -- We acquire the write and stateRef locks, to make sure that this is
        -- the only thread that can write to the stream and to perform a
        -- withConnection calculation. Afterwards, we release the lock and
        -- fetch an updated state.
        Stream
s <- forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
Ex.catch
            (forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
                 ByteString -> IO (Either XmppFailure ())
_ <- forall a. TMVar a -> STM a
takeTMVar (Session -> WriteSemaphore
writeSemaphore Session
session)
                 Stream
s <- forall a. TMVar a -> STM a
takeTMVar (Session -> TMVar Stream
streamRef Session
session)
                 forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
wait ()
                 forall (m :: * -> *) a. Monad m => a -> m a
return Stream
s
            )
            -- If we catch an exception, we have failed to take the MVars above.
            (\SomeException
e -> forall a. STM a -> IO a
atomically (forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
wait ()) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                 forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
Ex.throwIO (SomeException
e :: Ex.SomeException)
            )
        -- Run the XmppMonad action, save the (possibly updated) states, release
        -- the locks, and return the result.
        forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> [Handler m a] -> m a
Ex.catches
            (do
                 (b
res, Stream
s') <- Stream -> IO (b, Stream)
a Stream
s
                 ByteString -> IO (Either XmppFailure ())
wl <- forall a. StateT StreamState IO a -> Stream -> IO a
withStream' (forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ StreamHandle -> ByteString -> IO (Either XmppFailure ())
streamSend forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamState -> StreamHandle
streamHandle) Stream
s'
                 forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
                     forall a. TMVar a -> a -> STM ()
putTMVar (Session -> WriteSemaphore
writeSemaphore Session
session) ByteString -> IO (Either XmppFailure ())
wl
                     forall a. TMVar a -> a -> STM ()
putTMVar (Session -> TMVar Stream
streamRef Session
session) Stream
s'
                     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right b
res
            ) -- TODO: DO we have to replace the MVars in case of ane exception?
            -- We treat all Exceptions as fatal. If we catch a StreamError, we
            -- return it. Otherwise, we throw an exception.
            [ forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Ex.Handler forall a b. (a -> b) -> a -> b
$ \XmppFailure
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (XmppFailure
e :: XmppFailure)
            , forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Ex.Handler forall a b. (a -> b) -> a -> b
$ \SomeException
e -> Stream -> IO (Either XmppFailure ())
killStream Stream
s
                  forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
Ex.throwIO (SomeException
e :: Ex.SomeException)
            ]

-- | Executes a function to update the event handlers.
modifyHandlers :: (EventHandlers -> EventHandlers) -> Session -> IO ()
modifyHandlers :: (EventHandlers -> EventHandlers) -> Session -> IO ()
modifyHandlers EventHandlers -> EventHandlers
f Session
session = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> (a -> a) -> STM ()
modifyTMVar_ (Session -> TMVar EventHandlers
eventHandlers Session
session) EventHandlers -> EventHandlers
f
  where
    -- Borrowing modifyTVar from
    -- http://hackage.haskell.org/packages/archive/stm/2.4/doc/html/src/Control-Concurrent-STM-TVar.html
    -- as it's not available in GHC 7.0.
    modifyTMVar_ :: TMVar a -> (a -> a) -> STM ()
    modifyTMVar_ :: forall a. TMVar a -> (a -> a) -> STM ()
modifyTMVar_ TMVar a
var a -> a
g = do
      a
x <- forall a. TMVar a -> STM a
takeTMVar TMVar a
var
      forall a. TMVar a -> a -> STM ()
putTMVar TMVar a
var (a -> a
g a
x)

-- | Changes the handler to be executed when the server connection is closed. To
-- avoid race conditions the initial value should be set in the configuration
-- when creating the session
setConnectionClosedHandler :: (XmppFailure -> Session -> IO ()) -> Session -> IO ()
setConnectionClosedHandler :: (XmppFailure -> Session -> IO ()) -> Session -> IO ()
setConnectionClosedHandler XmppFailure -> Session -> IO ()
eh Session
session = do
    (EventHandlers -> EventHandlers) -> Session -> IO ()
modifyHandlers (\EventHandlers
s -> EventHandlers
s{connectionClosedHandler :: XmppFailure -> IO ()
connectionClosedHandler =
                                 \XmppFailure
e -> XmppFailure -> Session -> IO ()
eh XmppFailure
e Session
session}) Session
session

runConnectionClosedHandler :: Session -> XmppFailure -> IO ()
runConnectionClosedHandler :: Session -> XmppFailure -> IO ()
runConnectionClosedHandler Session
session XmppFailure
e = do
    XmppFailure -> IO ()
h <- EventHandlers -> XmppFailure -> IO ()
connectionClosedHandler forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. STM a -> IO a
atomically (forall a. TMVar a -> STM a
readTMVar
                                                  forall a b. (a -> b) -> a -> b
$ Session -> TMVar EventHandlers
eventHandlers Session
session)
    XmppFailure -> IO ()
h XmppFailure
e

-- | Run an event handler.
runHandler :: (EventHandlers -> IO a) -> Session -> IO a
runHandler :: forall a. (EventHandlers -> IO a) -> Session -> IO a
runHandler EventHandlers -> IO a
h Session
session = EventHandlers -> IO a
h forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. STM a -> IO a
atomically (forall a. TMVar a -> STM a
readTMVar forall a b. (a -> b) -> a -> b
$ Session -> TMVar EventHandlers
eventHandlers Session
session)


-- | End the current XMPP session. Kills the associated threads and closes the
-- connection.
--
-- Note that XMPP clients (that have signalled availability) should send
-- \"Unavailable\" presence prior to disconnecting.
--
-- The connectionClosedHandler will not be called (to avoid possibly
-- reestablishing the connection).
endSession :: Session -> IO ()
endSession :: Session -> IO ()
endSession Session
session =  do -- TODO: This has to be idempotent (is it?)
    Session -> IO ()
stopThreads Session
session
    Either XmppFailure ()
_ <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall b.
(Stream -> IO (b, Stream)) -> Session -> IO (Either XmppFailure b)
withConnection Session
session forall a b. (a -> b) -> a -> b
$ \Stream
stream -> do
        ()
_ <- Stream -> IO ()
closeStreams Stream
stream
        forall (m :: * -> *) a. Monad m => a -> m a
return ((), Stream
stream)
    forall (m :: * -> *) a. Monad m => a -> m a
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 seconds, and then closes the connection.
closeConnection :: Session -> IO ()
closeConnection :: Session -> IO ()
closeConnection Session
session = do
    Either XmppFailure ()
_ <-forall a b c. (a -> b -> c) -> b -> a -> c
flip forall b.
(Stream -> IO (b, Stream)) -> Session -> IO (Either XmppFailure b)
withConnection Session
session forall a b. (a -> b) -> a -> b
$ \Stream
stream -> do
        ()
_ <- Stream -> IO ()
closeStreams Stream
stream
        forall (m :: * -> *) a. Monad m => a -> m a
return ((), Stream
stream)
    Session -> XmppFailure -> IO ()
runConnectionClosedHandler Session
session XmppFailure
StreamEndFailure