Merge remote-tracking branch 'philonous/master'

src/Network/XMPP/Concurrent/Monad.hs

@@ -200,6 +200,10 @@ modifyHandlers f = do
 setSessionEndHandler :: XMPP () -> XMPP ()
 setSessionEndHandler eh = modifyHandlers (\s -> s{sessionEndHandler = eh})
 
+setConnectionClosedHandler :: XMPP () -> XMPP ()
+setConnectionClosedHandler eh = modifyHandlers
+                                (\s -> s{connectionClosedHandler = eh})
+
 -- | run an event handler
 runHandler :: (EventHandlers -> XMPP a) -> XMPP a
 runHandler h = do

src/Network/XMPP/Concurrent/Threads.hs

@@ -116,7 +116,7 @@ handleIQResponse handlers iq = do
       iqID (Left err) = iqErrorID err
       iqID (Right iq') = iqResultID iq'
 
-writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO ()) -> IO ()
+writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO Bool) -> IO ()
 writeWorker stCh writeR = forever $ do
   (write, next) <- atomically $ (,) <$>
                      takeTMVar writeR <*>
@@ -134,14 +134,14 @@ startThreads
         , TVar IQHandlers
         , TChan Stanza
         , IO ()
-        , TMVar (BS.ByteString -> IO ())
+        , TMVar (BS.ByteString -> IO Bool)
         , TMVar XmppConnection
         , ThreadId
         , TVar EventHandlers
         )
 
 startThreads = do
-  writeLock <- newTMVarIO (\_ -> return ())
+  writeLock <- newTMVarIO (\_ -> return False)
   messageC <- newTChanIO
   presenceC <- newTChanIO
   outC <- newTChanIO
@@ -183,7 +183,7 @@ withSession :: Session -> XMPP a -> IO a
 withSession = flip runReaderT
 
 -- | Sends a blank space every 30 seconds to keep the connection alive
-connPersist ::  TMVar (BS.ByteString -> IO ()) -> IO ()
+connPersist ::  TMVar (BS.ByteString -> IO Bool) -> IO ()
 connPersist lock = forever $ do
   pushBS <- atomically $ takeTMVar lock
   pushBS " "

src/Network/XMPP/Concurrent/Types.hs

@@ -47,7 +47,7 @@ data Session = Session { messagesRef :: IORef (Maybe ( TChan (Either
                                            -- the original chan
                        , outCh :: TChan Stanza
                        , iqHandlers :: TVar IQHandlers
-                       , writeRef :: TMVar (BS.ByteString -> IO () )
+                       , writeRef :: TMVar (BS.ByteString -> IO Bool )
                        , readerThread :: ThreadId
                        , idGenerator :: IO StanzaId
                        , conStateRef :: TMVar XmppConnection

src/Network/XMPP/Monad.hs

@@ -9,6 +9,7 @@ import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class
 --import Control.Monad.Trans.Resource
 import qualified Control.Exception as Ex
+import qualified GHC.IO.Exception as Ex
 import           Control.Monad.State.Strict
 
 import           Data.ByteString as BS
@@ -30,19 +31,18 @@ import           System.IO
 import           Text.XML.Stream.Elements
 import           Text.XML.Stream.Parse as XP
 
-pushN :: Element -> XMPPConMonad ()
+pushN :: Element -> XMPPConMonad Bool
 pushN x = do
   sink <- gets sConPushBS
   liftIO . sink $ renderElement x
 
-push :: Stanza -> XMPPConMonad ()
+push :: Stanza -> XMPPConMonad Bool
 push = pushN . pickleElem xpStanza
 
-pushOpen :: Element -> XMPPConMonad ()
+pushOpen :: Element -> XMPPConMonad Bool
 pushOpen e = do
   sink <- gets sConPushBS
   liftIO . sink $ renderOpenElement e
-  return ()
 
 pullSink :: Sink Event IO b -> XMPPConMonad b
 pullSink snk = do
@@ -71,6 +71,12 @@ pullStanza = do
         Left e -> liftIO . Ex.throwIO $ StreamError e
         Right r -> return r
 
+catchPush p = Ex.catch (p >> return True)
+                       (\e -> case Ex.ioe_type e of
+                                   Ex.ResourceVanished -> return False
+                                   _ -> Ex.throwIO e
+                       )
+
 xmppFromHandle :: Handle
                -> Text
                -> XMPPConMonad a
@@ -82,7 +88,7 @@ xmppFromHandle handle hostname f = do
   let st = XmppConnection
              src
              (raw)
-             (BS.hPut handle)
+             (catchPush . BS.hPut handle)
              (Just handle)
              (SF Nothing [] [])
              XmppConnectionPlain
@@ -99,7 +105,7 @@ xmppNoConnection :: XmppConnection
 xmppNoConnection = XmppConnection
                { sConSrc    = zeroSource
                , sRawSrc    = zeroSource
-               , sConPushBS = \_ -> return ()
+               , sConPushBS = \_ -> return False
                , sConHandle = Nothing
                , sFeatures  = SF Nothing [] []
                , sConnectionState = XmppConnectionClosed
@@ -121,7 +127,7 @@ xmppRawConnect host hostname = do
   let st = XmppConnection
              src
              (raw)
-             (BS.hPut con)
+             (catchPush . BS.hPut con)
              (Just con)
              (SF Nothing [] [])
              XmppConnectionPlain

src/Network/XMPP/TLS.hs

@@ -66,7 +66,7 @@ startTLS params = Ex.handle (return . Left . TLSError)
                     { sRawSrc = raw
 --                  , sConSrc =  -- Note: this momentarily leaves us in an
                                  -- inconsistent state
-                    , sConPushBS = psh
+                    , sConPushBS = catchPush . psh
                     , sCloseConnection = TLS.bye ctx >> sCloseConnection x
                     })
       either (lift . Ex.throwIO) return =<< lift xmppRestartStream

src/Network/XMPP/Types.hs

@@ -711,7 +711,7 @@ data XmppConnectionState = XmppConnectionClosed  -- ^ No connection at
 data XmppConnection = XmppConnection
                { sConSrc          :: Source IO Event
                , sRawSrc          :: Source IO BS.ByteString
-               , sConPushBS       :: BS.ByteString -> IO ()
+               , sConPushBS       :: BS.ByteString -> IO Bool
                , sConHandle       :: Maybe Handle
                , sFeatures        :: ServerFeatures
                , sConnectionState :: XmppConnectionState