diff --git a/Network/IRC/Client.hs b/Network/IRC/Client.hs --- a/Network/IRC/Client.hs +++ b/Network/IRC/Client.hs @@ -136,7 +136,7 @@ , _realname = n , _password = Nothing , _channels = [] - , _ctcpVer = "irc-client-0.4.1.1" + , _ctcpVer = "irc-client-0.4.2.0" , _eventHandlers = defaultEventHandlers , _ignore = [] } diff --git a/Network/IRC/Client/Internal.hs b/Network/IRC/Client/Internal.hs --- a/Network/IRC/Client/Internal.hs +++ b/Network/IRC/Client/Internal.hs @@ -10,13 +10,13 @@ import Control.Applicative ((<$>)) import Control.Concurrent (forkIO) -import Control.Concurrent.STM (atomically, readTVar, retry) +import Control.Concurrent.STM (atomically, readTVar, retry, writeTVar) import Control.Exception (SomeException, catch, throwIO) import Control.Monad (unless) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Reader (runReaderT) import Data.ByteString (ByteString) -import Data.Conduit (Producer, Conduit, Consumer, (=$=), ($=), (=$), awaitForever, toProducer, yield) +import Data.Conduit (Producer, Conduit, Consumer, (=$=), ($=), (=$), await, awaitForever, toProducer, yield) import Data.Conduit.TMChan (closeTBMChan, isEmptyTBMChan, newTBMChanIO, sourceTBMChan, writeTBMChan) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Time.Clock (NominalDiffTime, getCurrentTime) @@ -77,6 +77,7 @@ -- Initialise the IRC session let initialise = flip runReaderT state $ do + liftIO . atomically $ writeTVar (_connState state) Connected mapM_ (\p -> sendBS $ rawMessage "PASS" [encodeUtf8 p]) password sendBS $ rawMessage "USER" [encodeUtf8 theUser, "-", "-", encodeUtf8 theReal] _onconnect =<< connectionConfig @@ -117,13 +118,17 @@ -- | Block on receiving a message and invoke all matching handlers -- concurrently. eventSink :: MonadIO m => IRCState s -> Consumer IrcEvent m () -eventSink ircstate = awaitForever $ \event -> do +eventSink ircstate = await >>= maybe (return ()) (\event -> do let event' = decodeUtf8 <$> event ignored <- isIgnored ircstate event' unless ignored $ do handlers <- getHandlersFor event' . _eventHandlers <$> getInstanceConfig' ircstate liftIO $ mapM_ (\h -> forkIO $ runReaderT (h event') ircstate) handlers + -- If disconnected, do not loop. + disconnected <- (==Disconnected) <$> getConnState ircstate + unless disconnected (eventSink ircstate)) + -- | Check if an event is ignored or not. isIgnored :: MonadIO m => IRCState s -> UnicodeEvent -> m Bool isIgnored ircstate ev = do @@ -195,18 +200,31 @@ -- (if there is one). disconnect :: StatefulIRC s () disconnect = do - queueS <- _sendqueue <$> connectionConfig + s <- ircState - -- Wait for all messages to be sent - liftIO . atomically $ do - empty <- isEmptyTBMChan queueS - unless empty retry + connState <- liftIO . atomically . readTVar $ _connState s + case connState of + Connected -> do + -- Set the state to @Disconnecting@ + liftIO . atomically $ writeTVar (_connState s) Disconnecting - -- Then close the connection - disconnectNow + -- Wait for all messages to be sent + queueS <- _sendqueue <$> connectionConfig + liftIO . atomically $ do + empty <- isEmptyTBMChan queueS + unless empty retry + -- Then close the connection + disconnectNow + + -- If already disconnected, or disconnecting, do nothing. + _ -> pure () + -- | Disconnect immediately, without waiting for messages to be sent. disconnectNow :: StatefulIRC s () disconnectNow = do queueS <- _sendqueue <$> connectionConfig liftIO . atomically $ closeTBMChan queueS + + s <- ircState + liftIO . atomically $ writeTVar (_connState s) Disconnected diff --git a/Network/IRC/Client/Types.hs b/Network/IRC/Client/Types.hs --- a/Network/IRC/Client/Types.hs +++ b/Network/IRC/Client/Types.hs @@ -42,18 +42,26 @@ -- ^Mutable user state , _instanceConfig :: TVar (InstanceConfig s) -- ^Mutable instance configuration in STM + , _connState :: TVar ConnectionState + -- ^State of the connection. } +-- | The state of the connection. +data ConnectionState = Connected | Disconnecting | Disconnected + deriving (Bounded, Enum, Eq, Ord, Read, Show) + -- | Construct a new IRC state newIRCState :: MonadIO m => ConnectionConfig s -> InstanceConfig s -> s -> m (IRCState s) newIRCState cconf iconf ustate = do ustvar <- liftIO . atomically . newTVar $ ustate ictvar <- liftIO . atomically . newTVar $ iconf + cstvar <- liftIO . atomically . newTVar $ Disconnected return IRCState { _connectionConfig = cconf , _userState = ustvar , _instanceConfig = ictvar + , _connState = cstvar } -- | Access the client state. @@ -71,6 +79,10 @@ -- | Extract the user state from an IRC state getUserState :: IRCState s -> TVar s getUserState = _userState + +-- | Extract the connection state from an IRC state. +getConnState :: MonadIO m => IRCState s -> m ConnectionState +getConnState = liftIO . atomically . readTVar . _connState -- | Extract the current snapshot of the instance configuration from -- an IRC state diff --git a/Network/IRC/Client/Utils.hs b/Network/IRC/Client/Utils.hs --- a/Network/IRC/Client/Utils.hs +++ b/Network/IRC/Client/Utils.hs @@ -64,3 +64,15 @@ -- | Construct a @NOTICE@ containing a CTCP ctcpReply :: Text -> Text -> [Text] -> UnicodeMessage ctcpReply t command args = Notice t . Left $ toCTCP command args + +-- | Check if the client is connected. +isConnected :: StatefulIRC s Bool +isConnected = (==Connected) <$> (getConnState =<< ircState) + +-- | Check if the client is in the process of disconnecting. +isDisconnecting :: StatefulIRC s Bool +isDisconnecting = (==Disconnecting) <$> (getConnState =<< ircState) + +-- | Check if the client is disconnected +isDisconnected :: StatefulIRC s Bool +isDisconnected = (==Disconnected) <$> (getConnState =<< ircState) diff --git a/irc-client.cabal b/irc-client.cabal --- a/irc-client.cabal +++ b/irc-client.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.4.1.1 +version: 0.4.2.0 -- A short (one-line) description of the package. synopsis: An IRC client library. @@ -82,18 +82,17 @@ -- other-extensions: -- Other library packages from which modules are imported. - build-depends: base >=4.7 && <5 - , bytestring >=0.10 && <0.11 - , conduit >=1.2 && <1.3 - , data-default-class >=0.0.1 && <0.1 - , irc-conduit >=0.1.1 && <0.3 - , irc-ctcp >=0.1.2 && <0.2 - , old-locale >=1.0 && <1.1 - , stm >=2.4 && <2.5 - , stm-conduit >=2.5 && <3.1 - , text >=1.1 && <1.3 - , time >=1.4 && <1.7 - , transformers >=0.3 && <0.6 + build-depends: base >=4.7 && <5 + , bytestring >=0.10 && <0.11 + , conduit >=1.2 && <1.3 + , irc-conduit >=0.1.1 && <0.3 + , irc-ctcp >=0.1.2 && <0.2 + , old-locale >=1.0 && <1.1 + , stm >=2.4 && <2.5 + , stm-conduit >=2.5 && <3.1 + , text >=1.1 && <1.3 + , time >=1.4 && <1.7 + , transformers >=0.3 && <0.6 -- Directories containing source files. -- hs-source-dirs: @@ -108,4 +107,4 @@ source-repository this type: git location: https://github.com/barrucadu/irc-client.git - tag: 0.4.1.1 + tag: 0.4.2.0