added EventHandlers, endSession, closeConnection

src/Data/Conduit/TLS.hs

@@ -26,7 +26,9 @@ tlsinit
      TLSParams
      -> Handle -> m ( Source m1 BS.ByteString
                     , Sink BS.ByteString m1 ()
-                    , BS.ByteString -> IO ())
+                    , BS.ByteString -> IO ()
+                    , TLSCtx Handle
+                    )
 tlsinit tlsParams handle = do
     gen <- liftIO $ (newGenIO :: IO SystemRandom) -- TODO: Find better random source?
     clientContext <- client tlsParams gen handle
@@ -41,5 +43,7 @@ tlsinit tlsParams handle = do
          (\_ -> return ())
     return ( src
            , snk
-           , \s -> sendData clientContext $ BL.fromChunks [s] )
+           , \s -> sendData clientContext $ BL.fromChunks [s]
+           , clientContext
+           )
 

src/Network/XMPP/Concurrent/Monad.hs

@@ -14,6 +14,7 @@ import qualified Data.Map as Map
 import           Data.Text(Text)
 
 import           Network.XMPP.Concurrent.Types
+import           Network.XMPP.Monad
 
 -- | Register a new IQ listener. IQ requests matching the type and namespace will
 -- be put in the channel.
@@ -162,8 +163,36 @@ withConnection a = do
     putTMVar stateRef s'
   return res
 
+-- | Send a presence Stanza
 sendPresence :: Presence -> XMPPThread ()
 sendPresence = sendS . PresenceS
 
+-- | Send a Message Stanza
 sendMessage :: Message -> XMPPThread ()
 sendMessage = sendS . MessageS
+
+
+modifyHandlers :: (EventHandlers -> EventHandlers) -> XMPPThread ()
+modifyHandlers f = do
+    eh <- asks eventHandlers
+    liftIO . atomically $ modifyTVar eh f
+
+setSessionEndHandler :: XMPPThread () -> XMPPThread ()
+setSessionEndHandler eh = modifyHandlers (\s -> s{sessionEndHandler = eh})
+
+-- | run an event handler
+runHandler :: (EventHandlers -> XMPPThread a) -> XMPPThread a
+runHandler h = do
+  eh <- liftIO . atomically . readTVar  =<< asks eventHandlers
+  h eh
+
+-- | End the current xmpp session
+endSession :: XMPPThread ()
+endSession = do -- TODO: This has to be idempotent (is it?)
+    withConnection xmppKillConnection
+    liftIO =<< asks stopThreads
+    runHandler sessionEndHandler
+
+-- | Close the connection to the server
+closeConnection :: XMPPThread ()
+closeConnection = withConnection xmppKillConnection

src/Network/XMPP/Concurrent/Threads.hs

@@ -130,6 +130,7 @@ startThreads
                   , TMVar (BS.ByteString -> IO ())
                   , TMVar XMPPConState
                   , ThreadId
+                  , TVar EventHandlers
                   )
 
 startThreads = do
@@ -139,6 +140,7 @@ startThreads = do
   iqC  <- liftIO newTChanIO
   outC <- liftIO  newTChanIO
   handlers <- liftIO $ newTVarIO ( Map.empty, Map.empty)
+  eh <- liftIO $ newTVarIO  zeroEventHandlers
   conS <- liftIO . newTMVarIO =<< get
   lw <- liftIO . forkIO $ writeWorker outC writeLock
   cp <- liftIO . forkIO $ connPersist writeLock
@@ -146,7 +148,7 @@ startThreads = do
   rd <- liftIO . forkIO $ readWorker messageC presenceC handlers conS
   return (messageC, presenceC, handlers, outC
          , killConnection writeLock [lw, rd, cp]
-         , writeLock, conS ,rd)
+         , writeLock, conS ,rd, eh)
   where
       killConnection writeLock threads = liftIO $ do
         _ <- atomically $ takeTMVar writeLock -- Should we put it back?
@@ -159,7 +161,7 @@ runThreaded  :: XMPPThread a
                 -> XMPPConMonad a
 runThreaded a = do
     liftIO . putStrLn $ "starting threads"
-    (mC, pC, hand, outC, _stopThreads, writeR, conS, rdr ) <- startThreads
+    (mC, pC, hand, outC, stopThreads', writeR, conS, rdr, eh) <- startThreads
     liftIO . putStrLn $ "threads running"
     workermCh <- liftIO . newIORef $ Nothing
     workerpCh <- liftIO . newIORef $ Nothing
@@ -170,7 +172,7 @@ runThreaded a = do
             return . read. show $ curId
     s <- get
     liftIO . putStrLn $ "starting application"
-    liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR rdr getId conS)
+    liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR rdr getId conS eh stopThreads')
 
 
 -- | Sends a blank space every 30 seconds to keep the connection alive

src/Network/XMPP/Concurrent/Types.hs

@@ -21,6 +21,16 @@ type IQHandlers = (Map.Map (IQRequestType, Text) (TChan (IQRequest, TVar Bool))
                   , Map.Map StanzaId (TMVar IQResponse)
                   )
 
+data EventHandlers = EventHandlers
+                         { sessionEndHandler       :: XMPPThread ()
+                         , connectionClosedHandler :: XMPPThread ()
+                         }
+
+zeroEventHandlers = EventHandlers
+                         { sessionEndHandler       = return ()
+                         , connectionClosedHandler = return ()
+                         }
+
 data Thread = Thread { messagesRef :: IORef (Maybe ( TChan (Either
                                                               MessageError
                                                               Message
@@ -39,6 +49,8 @@ data Thread = Thread { messagesRef :: IORef (Maybe ( TChan (Either
                      , readerThread :: ThreadId
                      , idGenerator :: IO StanzaId
                      , conStateRef :: TMVar XMPPConState
+                     , eventHandlers :: TVar EventHandlers
+                     , stopThreads :: IO ()
                      }
 
 type XMPPThread a = ReaderT Thread IO a

src/Network/XMPP/Monad.hs

@@ -80,10 +80,11 @@ xmppFromHandle handle hostname username res f = do
              (Just hostname)
              (Just username)
              res
+             (hClose handle)
   runStateT f st
 
 zeroSource :: Source IO output
-zeroSource = sourceState () (\_ -> forever $ threadDelay 10000000)
+zeroSource = liftIO . forever $ threadDelay 10000000
 
 xmppZeroConState :: XMPPConState
 xmppZeroConState = XMPPConState
@@ -96,6 +97,7 @@ xmppZeroConState = XMPPConState
                , sHostname  = Nothing
                , sUsername  = Nothing
                , sResource  = Nothing
+               , sCloseConnection = return ()
                }
 
 xmppRawConnect :: HostName -> Text -> XMPPConMonad ()
@@ -117,8 +119,16 @@ xmppRawConnect host hostname = do
              (Just hostname)
              uname
              Nothing
+             (hClose con)
   put st
 
+
 withNewSession :: XMPPConMonad a -> IO (a, XMPPConState)
 withNewSession action = do
   runStateT action xmppZeroConState
+
+xmppKillConnection :: XMPPConMonad ()
+xmppKillConnection = do
+    cc <- gets sCloseConnection
+    liftIO cc
+    put xmppZeroConState

src/Network/XMPP/SASL.hs

@@ -163,7 +163,6 @@ md5Digest uname realm password digestURI nc qop nonce cnonce=
       ha2 = hash ["AUTHENTICATE", digestURI]
   in hash [ha1,nonce, nc, cnonce,qop,ha2]
 
-
 -- Pickling
 failurePickle :: PU [Node] (SASLFailure)
 failurePickle = xpWrap (\(txt,(failure,_,_))

src/Network/XMPP/TLS.hs

@@ -68,12 +68,13 @@ xmppStartTLS params = Ex.handle (return . Left . TLSError)
       case answer of
         Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] -> return ()
         _ -> throwError $ TLSStreamError StreamXMLError
-      (raw, snk, psh) <- lift $ TLS.tlsinit params handle
+      (raw, snk, psh, ctx) <- lift $ TLS.tlsinit params handle
       lift $ modify (\x -> x
                     { sRawSrc = raw
 --                  , sConSrc =  -- Note: this momentarily leaves us in an
                                  -- inconsistent state
                     , sConPushBS = psh
+                    , sCloseConnection = TLS.bye ctx >> sCloseConnection x
                     })
       ErrorT $ (left TLSStreamError) <$> xmppRestartStream
       modify (\s -> s{sHaveTLS = True})

src/Network/XMPP/Types.hs

@@ -535,8 +535,6 @@ instance Read SASLError where
     readsPrec _ "not-authorized"         = [(SASLNotAuthorized        , "")]
     readsPrec _ "temporary-auth-failure" = [(SASLTemporaryAuthFailure , "")]
 
-
-
 -- | Readability type for host name Texts.
 
 -- type HostName = Text -- This is defined in Network as well
@@ -659,6 +657,7 @@ data XMPPConState = XMPPConState
                , sHostname  :: Maybe Text
                , sUsername  :: Maybe Text
                , sResource  :: Maybe Text
+               , sCloseConnection :: IO ()
                }
 
 -- |