diff --git a/Network/IRC/Client.hs b/Network/IRC/Client.hs --- a/Network/IRC/Client.hs +++ b/Network/IRC/Client.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Network.IRC.Client @@ -12,184 +12,225 @@ -- -- > run :: ByteString -> Int -> Text -> IO () -- > run host port nick = do --- > conn <- connect host port 1 --- > let cfg = defaultIRCConf nick --- > let cfg' = cfg { _eventHandlers = yourCustomEventHandlers : _eventHandlers cfg } --- > start conn cfg' +-- > let conn = plainConnection host port +-- > let cfg = defaultInstanceConfig nick & handlers %~ (yourCustomEventHandlers:) +-- > runClient conn cfg () -- -- You shouldn't really need to tweak anything other than the event -- handlers, as everything has been designed to be as simple as -- possible. module Network.IRC.Client - ( -- * Initialisation - connect - , connectWithTLS - , connectWithTLSConfig - , connectWithTLSVerify - , start - , start' - , startStateful + ( -- * Configuration - -- * Logging - , Origin (..) - , connect' - , connectWithTLS' - , connectWithTLSConfig' - , connectWithTLSVerify' + -- | The configuration is logically split into two parts: the + -- /connection/ configuration (the 'ConnectionConfig' type) and the + -- /instance/ configuration (the 'InstanceConfig' type). + -- + -- - Connection configuration details how to connect to the IRC + -- server, and cannot be modified after the client has started + -- (although it can be read). + -- + -- - Instance configuration is everything else: the client's + -- nick, and version, handlers for received messages, and so + -- on. It can be modified after the client has started. + + -- ** Connection configuration + + -- | The following values can be changed with the exported lenses: + -- + -- - 'username' (default: \"irc-client\"). The username sent to + -- the server in the \"USER\" command. + -- + -- - 'realname' (default: \"irc-client\"). The real name sent to + -- the server in the \"USER\" command. + -- + -- - 'password' (default: @Nothing@). If set, the password sent to the + -- server in the \"PASS\" command. + -- + -- - 'flood' (default: @1@). The minimum time between sending + -- messages, to avoid flooding. + -- + -- - 'timeout' (default: @300@). The amount of time to wait for a + -- message from the server before locally timing out. + -- + -- - 'onconnect' (default: 'defaultOnConnect'). The action to + -- perform after sending the \"USER\" and \"PASS\" commands. + -- + -- - 'ondisconnect' (default: 'defaultOnDisconnect'). The action + -- to perform after disconnecting from the server + -- + -- - 'logfunc' (default: 'noopLogger'). The function to log received + -- and sent messages. + + ConnectionConfig + , plainConnection + , TLSConfig(..) + , tlsConnection + + -- *** Logging + + -- | The logging functions are told whether the message came from + -- the server or the client, and are given the raw bytestring. + + , Origin(..) , stdoutLogger , fileLogger , noopLogger - -- * Interaction + -- ** Instance configuration + + -- | The following values can be changed with the exported lenses: + -- + -- - 'nick'. The nick that 'defaultOnConnect' sends to the + -- server. This is also modified during runtime by the + -- 'welcomeNick' and 'nickMangler' default event handlers. + -- + -- - 'channels' (default: @[]@). The channels that + -- 'joinOnWelcome' joins. This is also modified during runtime + -- by the 'joinHandler' default event handler. + -- + -- - 'version' (default: \"irc-client-$VERSION\"). The + -- version that 'ctcpVersionHandler' sends. + -- + -- - 'handlers' (default: 'defaultEventHandlers'). The list of + -- event handlers. + -- + -- - 'ignore' (default: @[]@). The ignore list, events from + -- matching nicks are not handled. + + , InstanceConfig + , defaultInstanceConfig + + -- * Writing IRC clients + + -- | With this library, IRC clients are mostly composed of event + -- handlers. Event handlers are monadic actions operating in the + -- 'IRC' monad. + + , IRC , send , sendBS , disconnect + , reconnect - -- * Defaults - , defaultIRCConf - , defaultOnConnect - , defaultOnDisconnect - , defaultEventHandlers + -- ** From event handlers - -- * Types - , module Network.IRC.Client.Types + , module Network.IRC.Client.Events + -- ** From the outside + + -- | The 'ConnectionConfig', 'InstanceConfig', and some other stuff + -- are combined in the 'IRCState' type. This can be used to interact + -- with a client from the outside, by providing a way to run @IRC s + -- a@ actions. + + , IRCState + , getIRCState + , runIRCAction + , ConnectionState(..) + , getConnectionState + + -- * Execution + , runClient + + -- | If an 'IRCState' is constructed with 'newIRCState' and a client + -- started with 'runClientWith', then 'runIRCAction' can be used to + -- interact with that client. + + , newIRCState + , runClientWith + + -- | If the client times out from the server, the 'Timeout' + -- exception will be thrown, killing it. + , Timeout(..) + + -- * Concurrency + + -- | A client can manage a collection of threads, which get thrown + -- the 'Disconnect' exception whenever the client disconnects for + -- any reason (including a call to 'reconnect'). These can be + -- created from event handlers to manage long-running tasks. + , U.fork + , Disconnect(..) + + -- * Lenses + , module Network.IRC.Client.Lens + -- * Utilities , module Network.IRC.Client.Utils , C.rawMessage , C.toByteString ) where -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Reader (runReaderT) -import Data.ByteString (ByteString) -import qualified Data.Conduit.Network.TLS as TLS -import Data.Text (Text) -import Data.Time.Clock (NominalDiffTime) -import qualified Data.X509 as X -import qualified Data.X509.CertificateStore as X -import qualified Data.X509.Validation as X -import qualified Network.Connection as TLS (TLSSettings(..)) -import Network.IRC.Client.Handlers -import Network.IRC.Client.Internal -import Network.IRC.Client.Types -import Network.IRC.Client.Utils -import qualified Network.IRC.Conduit as C -import qualified Network.TLS as TLS +import Control.Concurrent.STM (newTVarIO) +import Control.Concurrent.STM.TBMChan (newTBMChanIO) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.ByteString (ByteString) +import qualified Data.Conduit.Network.TLS as TLS +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import Data.Version (showVersion) +import qualified Data.X509 as X +import qualified Data.X509.CertificateStore as X +import qualified Data.X509.Validation as X +import Network.Connection as TLS (TLSSettings(..)) +import qualified Network.IRC.Conduit as C +import qualified Network.TLS as TLS --- * Connecting to an IRC network +import Network.IRC.Client.Events +import Network.IRC.Client.Internal +import Network.IRC.Client.Lens +-- I think exporting 'fork' with 'Disconnect' gives better documentation. +import Network.IRC.Client.Utils hiding (fork) +import qualified Network.IRC.Client.Utils as U --- | Connect to a server without TLS. -connect :: MonadIO m - => ByteString - -- ^ The hostname - -> Int - -- ^ The port - -> NominalDiffTime - -- ^ The flood cooldown - -> m (ConnectionConfig s) -connect = connect' noopLogger +import qualified Paths_irc_client as Paths --- | Connect to a server with TLS. -connectWithTLS :: MonadIO m - => ByteString - -- ^ The hostname - -> Int - -- ^ The port - -> NominalDiffTime - -- ^ The flood cooldown - -> m (ConnectionConfig s) -connectWithTLS = connectWithTLS' noopLogger --- | Connect to a server with TLS using the given TLS config. -connectWithTLSConfig :: MonadIO m - => TLS.TLSClientConfig - -- ^ The TLS config - -> NominalDiffTime - -- ^ The flood cooldown - -> m (ConnectionConfig s) -connectWithTLSConfig = connectWithTLSConfig' noopLogger - --- | Connect to a server with TLS using the given certificate --- verifier. -connectWithTLSVerify :: MonadIO m - => (X.CertificateStore -> TLS.ValidationCache -> X.ServiceID -> X.CertificateChain -> IO [X.FailedReason]) - -- ^ The certificate verifier. Returns an empty list if the cert is - -- good. - -> ByteString - -- ^ The hostname - -> Int - -- ^ The port - -> NominalDiffTime - -- ^ The flood cooldown - -> m (ConnectionConfig s) -connectWithTLSVerify = connectWithTLSVerify' noopLogger +------------------------------------------------------------------------------- +-- Configuration --- | Connect to a server without TLS, with the provided logging --- function. -connect' :: MonadIO m - => (Origin -> ByteString -> IO ()) - -- ^ The message logger - -> ByteString +-- | Connect to a server without TLS. +plainConnection + :: ByteString -- ^ The hostname -> Int -- ^ The port - -> NominalDiffTime - -- ^ The flood cooldown - -> m (ConnectionConfig s) -connect' lg host port = - connectInternal (C.ircClient port host) defaultOnConnect defaultOnDisconnect lg host port + -> ConnectionConfig s +plainConnection host port_ = + setupInternal (C.ircClient port_ host) defaultOnConnect defaultOnDisconnect noopLogger host port_ --- | Connect to a server with TLS, with the provided logging function. -connectWithTLS' :: MonadIO m - => (Origin -> ByteString -> IO ()) - -- ^ The message logger - -> ByteString - -- ^ The hostname - -> Int - -- ^ The port - -> NominalDiffTime - -- ^ The flood cooldown - -> m (ConnectionConfig s) -connectWithTLS' lg host port = - connectInternal (C.ircTLSClient port host) defaultOnConnect defaultOnDisconnect lg host port +-- | How to connect to a server over TLS. +data TLSConfig + = WithDefaultConfig ByteString Int + -- ^ Use @@. + | WithClientConfig TLS.TLSClientConfig + -- ^ Use the given configuration. The hostname and port are stored + -- as fields of the 'TLS.TLSClientConfig'. + | WithVerifier ByteString Int (X.CertificateStore -> TLS.ValidationCache -> X.ServiceID -> X.CertificateChain -> IO [X.FailedReason]) + -- ^ Use @@, + -- with the given certificate verifier. The certificate verifier is + -- a function which returns a list of reasons to reject the + -- certificate. --- | Connect to a server with TLS using the given TLS config, with the --- provided logging function. -connectWithTLSConfig' :: MonadIO m - => (Origin -> ByteString -> IO ()) - -- ^ The message logger - -> TLS.TLSClientConfig - -- ^ The TLS config - -> NominalDiffTime - -- ^ The flood cooldown - -> m (ConnectionConfig s) -connectWithTLSConfig' lg cfg = - connectInternal (C.ircTLSClient' cfg) defaultOnConnect defaultOnDisconnect lg host port +-- | Connect to a server with TLS. +tlsConnection + :: TLSConfig + -- ^ How to initiate the TLS connection + -> ConnectionConfig s +tlsConnection (WithDefaultConfig host port_) = + setupInternal (C.ircTLSClient port_ host) defaultOnConnect defaultOnDisconnect noopLogger host port_ +tlsConnection (WithClientConfig cfg) = + setupInternal (C.ircTLSClient' cfg) defaultOnConnect defaultOnDisconnect noopLogger host port_ where - host = TLS.tlsClientHost cfg - port = TLS.tlsClientPort cfg - --- | Connect to a server with TLS using the given certificate --- verifier, with the provided logging function. -connectWithTLSVerify' :: MonadIO m - => (Origin -> ByteString -> IO ()) - -- ^ The message logger - -> (X.CertificateStore -> TLS.ValidationCache -> X.ServiceID -> X.CertificateChain -> IO [X.FailedReason]) - -- ^ The certificate verifier. Returns an empty list if the cert is - -- good. - -> ByteString - -- ^ The hostname - -> Int - -- ^ The port - -> NominalDiffTime - -- ^ The flood cooldown - -> m (ConnectionConfig s) -connectWithTLSVerify' lg verifier host port = - connectInternal (C.ircTLSClient' cfg) defaultOnConnect defaultOnDisconnect lg host port + host = TLS.tlsClientHost cfg + port_ = TLS.tlsClientPort cfg +tlsConnection (WithVerifier host port_ verifier) = + setupInternal (C.ircTLSClient' cfg) defaultOnConnect defaultOnDisconnect noopLogger host port_ where cfg = - let cfg0 = C.defaultTLSConfig port host + let cfg0 = C.defaultTLSConfig port_ host -- this is a partial pattern match, but because I'm the -- author of irc-conduit I can do this. TLS.TLSSettings cTLSSettings = TLS.tlsClientTLSSettings cfg0 @@ -200,33 +241,56 @@ } } --- * Starting +-- | Construct a default IRC configuration from a nick +defaultInstanceConfig + :: Text + -- ^ The nick + -> InstanceConfig s +defaultInstanceConfig n = InstanceConfig + { _nick = n + , _channels = [] + , _version = T.append "irc-client-" (T.pack $ showVersion Paths.version) + , _handlers = defaultEventHandlers + , _ignore = [] + } --- | Run the event loop for a server, receiving messages and handing --- them off to handlers as appropriate. Messages will be logged to --- stdout. -start :: MonadIO m => ConnectionConfig () -> InstanceConfig () -> m () -start cconf iconf = startStateful cconf iconf () --- | like 'start' but for clients with state. -startStateful :: MonadIO m => ConnectionConfig s -> InstanceConfig s -> s -> m () -startStateful cconf iconf ustate = newIRCState cconf iconf ustate >>= start' +------------------------------------------------------------------------------- +-- Execution --- | Like 'start', but use the provided initial state. -start' :: MonadIO m => IRCState s -> m () -start' = liftIO . runReaderT runner +-- | Connect to the IRC server and run the client: receiving messages +-- and handing them off to handlers as appropriate. +runClient :: MonadIO m + => ConnectionConfig s + -> InstanceConfig s + -> s + -- ^ The initial value for the user state. + -> m () +runClient cconf iconf ustate = newIRCState cconf iconf ustate >>= runClientWith --- * Default configuration +-- | Like 'runClient', but use the provided initial +-- 'IRCState'. +-- +-- Multiple clients should not be run with the same 'IRCState'. The +-- utility of this is to be able to run @IRC s a@ actions in order to +-- interact with the client from the outside. +runClientWith :: MonadIO m => IRCState s -> m () +runClientWith = runIRCAction runner --- | Construct a default IRC configuration from a nick -defaultIRCConf :: Text -> InstanceConfig s -defaultIRCConf n = InstanceConfig - { _nick = n - , _username = n - , _realname = n - , _password = Nothing - , _channels = [] - , _ctcpVer = "irc-client-0.4.4" - , _eventHandlers = defaultEventHandlers - , _ignore = [] - } + +------------------------------------------------------------------------------- +-- State + +-- | Construct a new IRC state +newIRCState :: MonadIO m + => ConnectionConfig s + -> InstanceConfig s + -> s + -- ^ The initial value for the user state. + -> m (IRCState s) +newIRCState cconf iconf ustate = liftIO $ IRCState cconf + <$> newTVarIO ustate + <*> newTVarIO iconf + <*> (newTVarIO =<< newTBMChanIO 16) + <*> newTVarIO Disconnected + <*> newTVarIO S.empty diff --git a/Network/IRC/Client/Events.hs b/Network/IRC/Client/Events.hs new file mode 100644 --- /dev/null +++ b/Network/IRC/Client/Events.hs @@ -0,0 +1,329 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Network.IRC.Client.Events +-- Copyright : (c) 2017 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : CPP, OverloadedStrings, RankNTypes +-- +-- Events and event handlers. When a message is received from the +-- server, all matching handlers are executed sequentially in the +-- order that they appear in the 'handlers' list. +module Network.IRC.Client.Events + ( -- * Handlers + EventHandler(..) + , matchCTCP + , matchNumeric + , matchType + , matchWhen + + -- * Default handlers + , defaultEventHandlers + , defaultOnConnect + , defaultOnDisconnect + + -- ** Individual handlers + , pingHandler + , kickHandler + , ctcpPingHandler + , ctcpVersionHandler + , ctcpTimeHandler + , welcomeNick + , joinOnWelcome + , joinHandler + , nickMangler + + -- * Re-exported + , Event(..) + , Message(..) + , Source(..) + , module Network.IRC.Conduit.Lens + ) where + +import Control.Applicative ((<$>), (<|>)) +import Control.Concurrent.STM (atomically, modifyTVar, readTVar) +import Control.Monad.Catch (SomeException, fromException, + throwM) +import Control.Monad.IO.Class (liftIO) +import Data.Char (isAlphaNum) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text, breakOn, takeEnd, toUpper) +import Data.Time.Clock (getCurrentTime) +import Data.Time.Format (formatTime) +import Network.IRC.Conduit (Event(..), Message(..), + Source(..)) +import Network.IRC.Conduit.Lens +import Network.IRC.CTCP (fromCTCP) + +#if MIN_VERSION_time(1,5,0) +import Data.Time.Format (defaultTimeLocale) +#else +import System.Locale (defaultTimeLocale) +#endif + +import qualified Data.Text as T + +import Network.IRC.Client.Internal +import Network.IRC.Client.Lens +import Network.IRC.Client.Utils + + +------------------------------------------------------------------------------- +-- Handlers + +-- | Match the verb of a CTCP, ignoring case, and returning the arguments. +-- +-- > matchCTCP "ping" ":foo PRIVMSG #bar :\001PING\001" ==> Just [] +-- > matchCTCP "PING" ":foo PRIVMSG #bar :\001PING\001" ==> Just [] +-- > matchCTCP "ACTION" ":foo PRIVMSG #bar :\001ACTION dances\001" ==> Just ["dances"] +matchCTCP :: Text -> Event Text -> Maybe [Text] +matchCTCP verb ev = case _message ev of + Privmsg _ (Left ctcpbs) -> + let (v, args) = fromCTCP ctcpbs + in if toUpper verb == toUpper v + then Just args + else Nothing + _ -> Nothing + +-- | Match a numeric server message. Numeric messages are sent in +-- response to most things, such as connecting to the server, or +-- joining a channel. +-- +-- Numerics in the range 001 to 099 are informative messages, numerics +-- in the range 200 to 399 are responses to commands. Some common +-- numerics are: +-- +-- - 001 (RPL_WELCOME), sent after successfully connecting. +-- +-- - 331 (RPL_NOTOPIC), sent after joining a channel if it has no +-- topic. +-- +-- - 332 (RPL_TOPIC), sent after joining a channel if it has a +-- topic. +-- +-- - 432 (ERR_ERRONEUSNICKNAME), sent after trying to change to an +-- invalid nick. +-- +-- - 433 (ERR_NICKNAMEINUSE), sent after trying to change to a nick +-- already in use. +-- +-- - 436 (ERR_NICKCOLLISION), sent after trying to change to a nick +-- in use on another server. +-- +-- See Section 5 of @@ for a complete list. +-- +-- > matchNumeric 001 "001 :Welcome to irc.example.com" ==> True +-- > matchNumeric 332 "332 :#haskell: We like Haskell" ==> True +matchNumeric :: Int -> Event a -> Maybe [a] +matchNumeric num ev = case _message ev of + Numeric n args | num == n -> Just args + _ -> Nothing + +-- | Match events of the given type. Refer to +-- "Network.IRC.Conduit.Lens#Message" for the list of 'Prism''s. +-- +-- > matchType _Privmsg ":foo PRIVMSG #bar :hello world" ==> Just ("#bar", Right "hello world") +-- > matchType _Quit ":foo QUIT :goodbye world" ==> Just (Just "goodbye world") +matchType :: Prism' (Message a) b -> Event a -> Maybe b +matchType k = preview k . _message + +-- | Match a predicate against an event. +-- +-- > matchWhen (const True) ":foo PRIVMSG #bar :hello world" ==> Just ":foo PRIVMSG :hello world" +matchWhen :: (Event a -> Bool) -> Event a -> Maybe (Message a) +matchWhen p ev | p ev = Just (_message ev) +matchWhen _ _ = Nothing + + +------------------------------------------------------------------------------- +-- Default handlers + +-- | The default event handlers, the following are included: +-- +-- - respond to server @PING@ messages with a @PONG@; +-- - respond to CTCP @PING@ requests; +-- - respond to CTCP @VERSION@ requests with the version string; +-- - respond to CTCP @TIME@ requests with the system time; +-- - update the nick upon receiving the welcome message, in case the +-- server modifies it; +-- - mangle the nick if the server reports a collision; +-- - update the channel list on @JOIN@ and @KICK@. +defaultEventHandlers :: [EventHandler s] +defaultEventHandlers = + [ pingHandler + , kickHandler + , ctcpPingHandler + , ctcpTimeHandler + , ctcpVersionHandler + , welcomeNick + , joinOnWelcome + , joinHandler + , nickMangler + ] + +-- | The default connect handler: set the nick. +defaultOnConnect :: IRC s () +defaultOnConnect = do + iconf <- snapshot instanceConfig =<< getIRCState + send . Nick $ get nick iconf + +-- | The default disconnect handler +-- +-- - If the client disconnected due to a 'Timeout' exception, reconnect. +-- +-- - If the client disconnected due to another exception, rethrow it. +-- +-- - If the client disconnected without an exception, halt. +defaultOnDisconnect :: Maybe SomeException -> IRC s () +defaultOnDisconnect (Just exc) = case fromException exc of + Just Timeout -> reconnect + Nothing -> throwM exc +defaultOnDisconnect Nothing = pure () + + +------------------------------------------------------------------------------- +-- Individual handlers + +-- | Respond to server @PING@ messages with a @PONG@. +pingHandler :: EventHandler s +pingHandler = EventHandler (matchType _Ping) $ \_ (s1, s2) -> + send . Pong $ fromMaybe s1 s2 + +-- | Respond to CTCP @PING@ requests. +ctcpPingHandler :: EventHandler s +ctcpPingHandler = EventHandler (matchCTCP "PING") $ \src args -> case src of + User n -> send $ ctcpReply n "PING" args + _ -> pure () + +-- | Respond to CTCP @VERSION@ requests with the version string. +ctcpVersionHandler :: EventHandler s +ctcpVersionHandler = EventHandler (matchCTCP "VERSION") $ \src _ -> case src of + User n -> do + ver <- get version <$> (snapshot instanceConfig =<< getIRCState) + send $ ctcpReply n "VERSION" [ver] + _ -> pure () + +-- | Respond to CTCP @TIME@ requests with the system time. +ctcpTimeHandler :: EventHandler s +ctcpTimeHandler = EventHandler (matchCTCP "TIME") $ \src _ -> case src of + User n -> do + now <- liftIO getCurrentTime + send $ ctcpReply n "TIME" [T.pack $ formatTime defaultTimeLocale "%c" now] + _ -> pure () + +-- | Update the nick upon welcome (numeric reply 001), as it may not +-- be what we requested (eg, in the case of a nick too long). +welcomeNick :: EventHandler s +welcomeNick = EventHandler (matchNumeric 001) $ \_ args -> case args of + (srvNick:_) -> do + tvarI <- get instanceConfig <$> getIRCState + liftIO . atomically $ + modifyTVar tvarI (set nick srvNick) + [] -> pure () + +-- | Join default channels upon welcome (numeric reply 001). If sent earlier, +-- the server might reject the JOIN attempts. +joinOnWelcome :: EventHandler s +joinOnWelcome = EventHandler (matchNumeric 001) $ \_ _ -> do + iconf <- snapshot instanceConfig =<< getIRCState + mapM_ (send . Join) $ get channels iconf + +-- | Mangle the nick if there's a collision (numeric replies 432, 433, +-- and 436) when we set it +nickMangler :: EventHandler s +nickMangler = EventHandler (\ev -> matcher 432 fresh ev <|> matcher 433 mangle ev <|> matcher 436 mangle ev) $ \_ -> uncurry go + where + matcher num f ev = case _message ev of + Numeric n args | num == n -> Just (f, args) + _ -> Nothing + + go f (_:srvNick:_) = do + theNick <- get nick <$> (snapshot instanceConfig =<< getIRCState) + + -- If the length of our nick and the server's idea of our nick + -- differ, it was truncated - so calculate the allowable length. + let nicklen = if T.length srvNick /= T.length theNick + then Just $ T.length srvNick + else Nothing + + setNick . trunc nicklen $ f srvNick + go _ _ = return () + + fresh n = if T.length n' == 0 then "f" else n' + where n' = T.filter isAlphaNum n + + mangle n = (n <> "1") `fromMaybe` charsubst n + + -- Truncate a nick, if there is a known length limit. + trunc len txt = maybe txt (`takeEnd` txt) len + + -- List of substring substitutions. It's important that these + -- don't contain any loops! + charsubst = transform [ ("i", "1") + , ("I", "1") + , ("l", "1") + , ("L", "1") + , ("o", "0") + , ("O", "0") + , ("A", "4") + , ("0", "1") + , ("1", "2") + , ("2", "3") + , ("3", "4") + , ("4", "5") + , ("5", "6") + , ("6", "7") + , ("7", "8") + , ("8", "9") + , ("9", "-") + ] + + -- Attempt to transform some text by the substitutions. + transform ((from, to):trs) txt = case breakOn' from txt of + Just (before, after) -> Just $ before <> to <> after + _ -> transform trs txt + transform [] _ = Nothing + +-- | Upon joining a channel (numeric reply 331 or 332), add it to the +-- list (if not already present). +joinHandler :: EventHandler s +joinHandler = EventHandler (\ev -> matchNumeric 331 ev <|> matchNumeric 332 ev) $ \_ args -> case args of + (c:_) -> do + tvarI <- get instanceConfig <$> getIRCState + liftIO . atomically $ + modifyTVar tvarI $ \iconf -> + (if c `elem` get channels iconf + then modify channels (c:) + else id) iconf + _ -> pure () + +-- | Update the channel list upon being kicked. +kickHandler :: EventHandler s +kickHandler = EventHandler (matchType _Kick) $ \src (n, _, _) -> do + tvarI <- get instanceConfig <$> getIRCState + liftIO . atomically $ do + theNick <- get nick <$> readTVar tvarI + case src of + Channel c _ + | n == theNick -> delChan tvarI c + | otherwise -> pure () + _ -> pure () + + +------------------------------------------------------------------------------- +-- Utils + +-- | Break some text on the first occurrence of a substring, removing +-- the substring from the second portion. +breakOn' :: Text -> Text -> Maybe (Text, Text) +breakOn' delim txt = if T.length after >= T.length delim + then Just (before, T.drop (T.length delim) after) + else Nothing + where + (before, after) = breakOn delim txt diff --git a/Network/IRC/Client/Handlers.hs b/Network/IRC/Client/Handlers.hs deleted file mode 100644 --- a/Network/IRC/Client/Handlers.hs +++ /dev/null @@ -1,250 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - --- | --- Module : Network.IRC.Client.Handlers --- Copyright : (c) 2016 Michael Walker --- License : MIT --- Maintainer : Michael Walker --- Stability : experimental --- Portability : CPP, OverloadedStrings --- --- The default event handlers. Handlers are invoked concurrently when --- matching events are received from the server. -module Network.IRC.Client.Handlers - ( -- * Event handlers - defaultEventHandlers - , pingHandler - , ctcpPingHandler - , ctcpVersionHandler - , ctcpTimeHandler - , welcomeNick - , joinOnWelcome - , nickMangler - - -- * Special handlers - , defaultOnConnect - , defaultOnDisconnect - ) where - -import Control.Applicative ((<$>)) -import Control.Arrow (first) -import Control.Concurrent.STM (atomically, readTVar, writeTVar) -import Control.Monad (unless) -import Control.Monad.IO.Class (liftIO) -import Data.Char (isAlphaNum) -import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) -import Data.Text (Text, breakOn, takeEnd, toUpper) -import Data.Time.Clock (getCurrentTime) -import Data.Time.Format (formatTime) -import Network.IRC.CTCP (fromCTCP) -import Network.IRC.Client.Types -import Network.IRC.Client.Utils -import Network.IRC.Client.Internal - -#if MIN_VERSION_time(1,5,0) -import Data.Time.Format (defaultTimeLocale) -#else -import System.Locale (defaultTimeLocale) -#endif - -import qualified Data.Text as T - --- * Event handlers - --- | The default event handlers, the following are included: --- --- - respond to server @PING@ messages with a @PONG@; --- - respond to CTCP @PING@ requests with a CTCP @PONG@; --- - respond to CTCP @VERSION@ requests with the version string; --- - respond to CTCP @TIME@ requests with the system time; --- - update the nick upon receiving the welcome message, in case the --- server modifies it; --- - mangle the nick if the server reports a collision; --- - update the channel list on @JOIN@ and @KICK@. --- --- These event handlers are all exposed through the --- Network.IRC.Client.Handlers module, so you can use them directly if --- you are building up your 'InstanceConfig' from scratch. --- --- If you are building a bot, you may want to write an event handler --- to process messages representing commands. -defaultEventHandlers :: [EventHandler s] -defaultEventHandlers = - [ EventHandler "Respond to server PING requests" EPing pingHandler - , EventHandler "Respond to CTCP PING requests" ECTCP ctcpPingHandler - , EventHandler "Respond to CTCP VERSION requests" ECTCP ctcpVersionHandler - , EventHandler "Respond to CTCP TIME requests" ECTCP ctcpTimeHandler - , EventHandler "Update the nick upon welcome" ENumeric welcomeNick - , EventHandler "Join channels upon welcome" ENumeric joinOnWelcome - , EventHandler "Mangle the nick on collision" ENumeric nickMangler - , EventHandler "Update the channel list on JOIN" ENumeric joinHandler - , EventHandler "Update the channel lift on KICK" EKick kickHandler - ] - --- | Respond to server @PING@ messages with a @PONG@. -pingHandler :: UnicodeEvent -> StatefulIRC s () -pingHandler ev = case _message ev of - Ping s1 s2 -> send . Pong $ fromMaybe s1 s2 - _ -> return () - --- | Respond to CTCP @PING@ requests with a CTCP @PONG@. -ctcpPingHandler :: UnicodeEvent -> StatefulIRC s () -ctcpPingHandler = ctcpHandler [("PING", return)] - --- | Respond to CTCP @VERSION@ requests with the version string. -ctcpVersionHandler :: UnicodeEvent -> StatefulIRC s () -ctcpVersionHandler = ctcpHandler [("VERSION", go)] where - go _ = do - ver <- _ctcpVer <$> instanceConfig - return [ver] - --- | Respond to CTCP @TIME@ requests with the system time. -ctcpTimeHandler :: UnicodeEvent -> StatefulIRC s () -ctcpTimeHandler = ctcpHandler [("TIME", go)] where - go _ = do - now <- liftIO getCurrentTime - return [T.pack $ formatTime defaultTimeLocale "%c" now] - --- | Update the nick upon welcome (numeric reply 001), as it may not --- be what we requested (eg, in the case of a nick too long). -welcomeNick :: UnicodeEvent -> StatefulIRC s () -welcomeNick = numHandler [(001, go)] where - go (srvNick:_) = do - tvarI <- instanceConfigTVar - - liftIO . atomically $ do - iconf <- readTVar tvarI - writeTVar tvarI iconf { _nick = srvNick } - go _ = return () - --- | Join default channels upon welcome (numeric reply 001). If sent earlier, --- the server might reject the JOIN attempts. -joinOnWelcome :: UnicodeEvent -> StatefulIRC s () -joinOnWelcome = numHandler [(001, go)] where - go _ = do - iconf <- instanceConfig - mapM_ (send . Join) $ _channels iconf - --- | Mangle the nick if there's a collision (numeric replies 432, 433, --- and 436) when we set it -nickMangler :: UnicodeEvent -> StatefulIRC s () -nickMangler = numHandler [ (432, go fresh) - , (433, go mangle) - , (436, go mangle) - ] - where - go f (_:srvNick:_) = do - theNick <- _nick <$> instanceConfig - - -- If the length of our nick and the server's idea of our nick - -- differ, it was truncated - so calculate the allowable length. - let nicklen = if T.length srvNick /= T.length theNick - then Just $ T.length srvNick - else Nothing - - setNick . trunc nicklen $ f srvNick - go _ _ = return () - - fresh n = if T.length n' == 0 then "f" else n' - where n' = T.filter isAlphaNum n - - mangle n = (n <> "1") `fromMaybe` charsubst n - - -- Truncate a nick, if there is a known length limit. - trunc len txt = maybe txt (`takeEnd` txt) len - - -- List of substring substitutions. It's important that these - -- don't contain any loops! - charsubst = transform [ ("i", "1") - , ("I", "1") - , ("l", "1") - , ("L", "1") - , ("o", "0") - , ("O", "0") - , ("A", "4") - , ("0", "1") - , ("1", "2") - , ("2", "3") - , ("3", "4") - , ("4", "5") - , ("5", "6") - , ("6", "7") - , ("7", "8") - , ("8", "9") - , ("9", "-") - ] - - -- Attempt to transform some text by the substitutions. - transform ((from, to):trs) txt = case breakOn' from txt of - Just (before, after) -> Just $ before <> to <> after - _ -> transform trs txt - transform [] _ = Nothing - --- | Upon receiving a channel topic (numeric reply 332), add the --- channel to the list (if not already present). -joinHandler :: UnicodeEvent -> StatefulIRC s () -joinHandler = numHandler [(332, go)] where - go (c:_) = do - tvarI <- instanceConfigTVar - - liftIO . atomically $ do - iconf <- readTVar tvarI - unless (c `elem` _channels iconf) $ - writeTVar tvarI iconf { _channels = c : _channels iconf } - - go _ = return () - --- | Update the channel list upon being kicked. -kickHandler :: UnicodeEvent -> StatefulIRC s () -kickHandler ev = do - theNick <- _nick <$> instanceConfig - tvarI <- instanceConfigTVar - - case (_source ev, _message ev) of - (Channel c _, Kick n _ _) | n == theNick -> liftIO . atomically $ delChan tvarI c - | otherwise -> return () - _ -> return () - --- *Special - --- | The default connect handler: set the nick. -defaultOnConnect :: StatefulIRC s () -defaultOnConnect = do - iconf <- instanceConfig - send . Nick $ _nick iconf - --- | The default disconnect handler: do nothing. You might want to --- override this with one which reconnects. -defaultOnDisconnect :: StatefulIRC s () -defaultOnDisconnect = return () - --- *Utils - --- | Match and handle a named CTCP -ctcpHandler :: [(Text, [Text] -> StatefulIRC s [Text])] -> UnicodeEvent -> StatefulIRC s () -ctcpHandler hs ev = case (_source ev, _message ev) of - (User n, Privmsg _ (Left ctcpbs)) -> - let (verb, xs) = first toUpper $ fromCTCP ctcpbs - in case lookup verb hs of - Just f -> do - args <- f xs - send $ ctcpReply n verb args - _ -> return () - _ -> return () - --- | Match and handle a numeric reply -numHandler :: [(Int, [Text] -> StatefulIRC s ())] -> UnicodeEvent -> StatefulIRC s () -numHandler hs ev = case _message ev of - Numeric num xs -> maybe (return ()) ($xs) $ lookup num hs - _ -> return () - --- | Break some text on the first occurrence of a substring, removing --- the substring from the second portion. -breakOn' :: Text -> Text -> Maybe (Text, Text) -breakOn' delim txt = if T.length after >= T.length delim - then Just (before, T.drop (T.length delim) after) - else Nothing - where - (before, after) = breakOn delim txt 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 @@ -1,6 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | @@ -9,7 +8,7 @@ -- License : MIT -- Maintainer : Michael Walker -- Stability : experimental --- Portability : CPP, OverloadedStrings, RankNTypes, ScopedTypeVariables +-- Portability : CPP, OverloadedStrings, ScopedTypeVariables -- -- Most of the hairy code. This isn't all internal, due to messy -- dependencies, but I've tried to make this as \"internal\" as @@ -17,39 +16,65 @@ -- -- This module is NOT considered to form part of the public interface -- of this library. -module Network.IRC.Client.Internal where +module Network.IRC.Client.Internal + ( module Network.IRC.Client.Internal + , module Network.IRC.Client.Internal.Lens + , module Network.IRC.Client.Internal.Types + ) where -import Control.Applicative ((<$>)) -import Control.Concurrent (forkIO) -import Control.Concurrent.STM (atomically, readTVar, writeTVar) -import Control.Exception (SomeException, catch, throwIO) -import Control.Monad (unless, when) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Reader (runReaderT) -import Data.ByteString (ByteString) -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, addUTCTime, getCurrentTime) -import Data.Time.Format (formatTime) -import Network.IRC.Conduit (IrcEvent, IrcMessage, floodProtector, rawMessage, toByteString) -import Network.IRC.Client.Types +import Control.Applicative ((<$>)) +import Control.Concurrent (forkIO, killThread, + myThreadId, threadDelay, + throwTo) +import Control.Concurrent.STM (STM, atomically, readTVar, + readTVarIO, writeTVar) +import Control.Concurrent.STM.TBMChan (TBMChan, closeTBMChan, + isClosedTBMChan, + isEmptyTBMChan, newTBMChan, + readTBMChan, writeTBMChan) +import Control.Monad (forM_, unless, void, when) +import Control.Monad.Catch (SomeException, catch) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (ask, runReaderT) +import Data.ByteString (ByteString, isPrefixOf) +import Data.Conduit (ConduitM, await, + awaitForever, yield, (.|)) +import Data.IORef (IORef, newIORef, readIORef, + writeIORef) +import qualified Data.Set as S +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Time.Clock (NominalDiffTime, UTCTime, + addUTCTime, diffUTCTime, + getCurrentTime) +import Data.Time.Format (formatTime) +import Data.Void (Void) +import Network.IRC.Conduit (Event(..), Message(..), + Source(..), floodProtector, + rawMessage, toByteString) #if MIN_VERSION_time(1,5,0) -import Data.Time.Format (defaultTimeLocale) +import Data.Time.Format (defaultTimeLocale) #else -import System.Locale (defaultTimeLocale) +import System.Locale (defaultTimeLocale) #endif --- * Connecting to an IRC network +import Network.IRC.Client.Internal.Lens +import Network.IRC.Client.Internal.Types +import Network.IRC.Client.Lens --- | Connect to a server using the supplied connection function. -connectInternal :: MonadIO m - => (IO () -> Consumer (Either ByteString IrcEvent) IO () -> Producer IO IrcMessage -> IO ()) + +------------------------------------------------------------------------------- +-- * Configuration + +-- | Config to connect to a server using the supplied connection +-- function. +setupInternal + :: (IO () -> ConduitM (Either ByteString (Event ByteString)) Void IO () -> ConduitM () (Message ByteString) IO () -> IO ()) -- ^ Function to start the network conduits. - -> StatefulIRC s () + -> IRC s () -- ^ Connect handler - -> StatefulIRC s () + -> (Maybe SomeException -> IRC s ()) -- ^ Disconnect handler -> (Origin -> ByteString -> IO ()) -- ^ Logging function @@ -57,92 +82,111 @@ -- ^ Server hostname -> Int -- ^ Server port - -> NominalDiffTime - -- ^ Flood timeout - -> m (ConnectionConfig s) -connectInternal f onconnect ondisconnect logf host port flood = liftIO $ do - queueS <- newTBMChanIO 16 + -> ConnectionConfig s +setupInternal f oncon ondis logf host port_ = ConnectionConfig + { _func = f + , _username = "irc-client" + , _realname = "irc-client" + , _password = Nothing + , _server = host + , _port = port_ + , _flood = 1 + , _timeout = 300 + , _onconnect = oncon + , _ondisconnect = ondis + , _logfunc = logf + } - return ConnectionConfig - { _func = f - , _sendqueue = queueS - , _server = host - , _port = port - , _flood = flood - , _onconnect = onconnect - , _ondisconnect = ondisconnect - , _logfunc = logf - } +------------------------------------------------------------------------------- -- * Event loop -- | The event loop. -runner :: StatefulIRC s () +runner :: IRC s () runner = do - state <- ircState + state <- getIRCState + let cconf = _connectionConfig state -- Set the real- and user-name - theUser <- _username <$> instanceConfig - theReal <- _realname <$> instanceConfig - password <- _password <$> instanceConfig + let theUser = get username cconf + let theReal = get realname cconf + let thePass = get password cconf -- Initialise the IRC session - let initialise = flip runReaderT state $ do - liftIO . atomically $ writeTVar (_connState state) Connected - mapM_ (\p -> sendBS $ rawMessage "PASS" [encodeUtf8 p]) password + let initialise = flip runIRCAction state $ do + liftIO . atomically $ writeTVar (_connectionState state) Connected + mapM_ (\p -> sendBS $ rawMessage "PASS" [encodeUtf8 p]) thePass sendBS $ rawMessage "USER" [encodeUtf8 theUser, "-", "-", encodeUtf8 theReal] - _onconnect =<< connectionConfig + _onconnect cconf -- Run the event loop, and call the disconnect handler if the remote -- end closes the socket. - cconf <- connectionConfig - let flood = _flood cconf - let func = _func cconf - let logf = _logfunc cconf - let queue = _sendqueue cconf + antiflood <- liftIO $ floodProtector (_flood cconf) - antiflood <- liftIO $ floodProtector flood + -- An IORef to keep track of the time of the last received message, to allow a local timeout. + lastReceived <- liftIO $ newIORef =<< getCurrentTime - dchandler <- _ondisconnect <$> connectionConfig + squeue <- liftIO . readTVarIO $ _sendqueue state - let source = toProducer $ sourceTBMChan queue $= antiflood $= logConduit (logf FromClient . toByteString) - let sink = forgetful =$= logConduit (logf FromServer . _raw) =$ eventSink state + let source = sourceTBMChan squeue + .| antiflood + .| logConduit (_logfunc cconf FromClient . toByteString . concealPass) + let sink = forgetful + .| logConduit (_logfunc cconf FromServer . _raw) + .| eventSink lastReceived state + -- Fork a thread to disconnect if the timeout elapses. + mainTId <- liftIO myThreadId + let time = _timeout cconf + let delayms = 1000000 * round time + let timeoutThread = do + now <- getCurrentTime + prior <- readIORef lastReceived + if diffUTCTime now prior >= time + then throwTo mainTId Timeout + else threadDelay delayms >> timeoutThread + timeoutTId <- liftIO (forkIO timeoutThread) + + -- Start the client. (exc :: Maybe SomeException) <- liftIO $ catch - (func initialise sink source >> pure Nothing) + (_func cconf initialise sink source >> killThread timeoutTId >> pure Nothing) (pure . Just) disconnect - dchandler - - -- If the connection terminated due to an exception, rethrow it. - liftIO $ maybe (pure ()) throwIO exc + _ondisconnect cconf exc -- | Forget failed decodings. -forgetful :: Monad m => Conduit (Either a b) m b +forgetful :: Monad m => ConduitM (Either a b) b m () forgetful = awaitForever go where go (Left _) = return () go (Right b) = yield b --- | Block on receiving a message and invoke all matching handlers --- concurrently. -eventSink :: MonadIO m => IRCState s -> Consumer IrcEvent m () -eventSink ircstate = go where +-- | Block on receiving a message and invoke all matching handlers. +eventSink :: MonadIO m => IORef UTCTime -> IRCState s -> ConduitM (Event ByteString) o m () +eventSink lastReceived ircstate = go where go = await >>= maybe (return ()) (\event -> do - let event' = decodeUtf8 <$> event + -- Record the current time. + now <- liftIO getCurrentTime + liftIO $ writeIORef lastReceived now + + -- Handle the event. + 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 + unless ignored . liftIO $ do + iconf <- snapshot instanceConfig ircstate + forM_ (get handlers iconf) $ \(EventHandler matcher handler) -> + maybe (pure ()) + (void . flip runIRCAction ircstate . handler (_source event')) + (matcher event') -- If disconnected, do not loop. - disconnected <- (==Disconnected) <$> getConnState ircstate + disconnected <- liftIO . atomically $ (==Disconnected) <$> getConnectionState ircstate unless disconnected go) -- | Check if an event is ignored or not. -isIgnored :: MonadIO m => IRCState s -> UnicodeEvent -> m Bool +isIgnored :: MonadIO m => IRCState s -> Event Text -> m Bool isIgnored ircstate ev = do - iconf <- liftIO . atomically . readTVar . _instanceConfig $ ircstate + iconf <- liftIO . readTVarIO . _instanceConfig $ ircstate let ignoreList = _ignore iconf return $ @@ -151,12 +195,8 @@ Channel c n -> ((n, Nothing) `elem` ignoreList) || ((n, Just c) `elem` ignoreList) Server _ -> False --- |Get the event handlers for an event. -getHandlersFor :: Event a -> [EventHandler s] -> [UnicodeEvent -> StatefulIRC s ()] -getHandlersFor e ehs = [_eventFunc eh | eh <- ehs, _matchType eh `elem` [EEverything, eventType e]] - -- |A conduit which logs everything which goes through it. -logConduit :: MonadIO m => (a -> IO ()) -> Conduit a m a +logConduit :: MonadIO m => (a -> IO ()) -> ConduitM a a m () logConduit logf = awaitForever $ \x -> do -- Call the logging function liftIO $ logf x @@ -191,59 +231,122 @@ noopLogger :: a -> b -> IO () noopLogger _ _ = return () +-- | Clear passwords from logs. +concealPass :: Message ByteString -> Message ByteString +concealPass (RawMsg msg) + | "PASS " `isPrefixOf` msg = rawMessage "PASS" [""] +concealPass m = m + + +------------------------------------------------------------------------------- -- * Messaging -- | Send a message as UTF-8, using TLS if enabled. This blocks if -- messages are sent too rapidly. -send :: UnicodeMessage -> StatefulIRC s () +send :: Message Text -> IRC s () send = sendBS . fmap encodeUtf8 -- | Send a message, using TLS if enabled. This blocks if messages are -- sent too rapidly. -sendBS :: IrcMessage -> StatefulIRC s () +sendBS :: Message ByteString -> IRC s () sendBS msg = do - queue <- _sendqueue <$> connectionConfig - liftIO . atomically $ writeTBMChan queue msg + qv <- _sendqueue <$> getIRCState + liftIO . atomically $ flip writeTBMChan msg =<< readTVar qv + +------------------------------------------------------------------------------- -- * Disconnecting -- | Disconnect from the server, properly tearing down the TLS session -- (if there is one). -disconnect :: StatefulIRC s () +disconnect :: IRC s () disconnect = do - s <- ircState + s <- getIRCState - connState <- liftIO . atomically . readTVar $ _connState s - case connState of - Connected -> do - -- Set the state to @Disconnecting@ - liftIO . atomically $ writeTVar (_connState s) Disconnecting + liftIO $ do + connState <- readTVarIO (_connectionState s) + case connState of + Connected -> do + -- Set the state to @Disconnecting@ + atomically $ writeTVar (_connectionState s) Disconnecting - -- Wait for all messages to be sent, or a minute has passed. - queueS <- _sendqueue <$> connectionConfig - timeout 60 . atomically $ isEmptyTBMChan queueS + -- Wait for all messages to be sent, or a minute has passed. + timeoutBlock 60 . atomically $ do + queue <- readTVar (_sendqueue s) + (||) <$> isEmptyTBMChan queue <*> isClosedTBMChan queue - -- Then close the connection - disconnectNow + -- Close the chan, which closes the sending conduit, and set + -- the state to @Disconnected@. + atomically $ do + closeTBMChan =<< readTVar (_sendqueue s) + writeTVar (_connectionState s) Disconnected - -- If already disconnected, or disconnecting, do nothing. - _ -> pure () + -- Kill all managed threads. Don't wait for them to terminate + -- here, as they might be masking exceptions and not pick up + -- the 'Disconnect' for a while; just clear the list. + mapM_ (`throwTo` Disconnect) =<< readTVarIO (_runningThreads s) + atomically $ writeTVar (_runningThreads s) S.empty --- | Disconnect immediately, without waiting for messages to be sent. -disconnectNow :: StatefulIRC s () -disconnectNow = do - queueS <- _sendqueue <$> connectionConfig - liftIO . atomically $ closeTBMChan queueS + -- If already disconnected, or disconnecting, do nothing. + _ -> pure () - s <- ircState - liftIO . atomically $ writeTVar (_connState s) Disconnected +-- | Disconnect from the server (this will wait for all messages to be +-- sent, or a minute to pass), and then connect again. +-- +-- This can be called after the client has already disconnected, in +-- which case it will just connect again. +-- +-- Like 'runClient' and 'runClientWith', this will not return until +-- the client terminates (ie, disconnects without reconnecting). +reconnect :: IRC s () +reconnect = do + disconnect + -- create a new send queue + s <- getIRCState + liftIO . atomically $ + writeTVar (_sendqueue s) =<< newTBMChan 16 + + runner + + +------------------------------------------------------------------------------- +-- * Utils + +-- | Interact with a client from the outside, by using its 'IRCState'. +runIRCAction :: MonadIO m => IRC s a -> IRCState s -> m a +runIRCAction ma = liftIO . runReaderT (runIRC ma) + +-- | Access the client state. +getIRCState :: IRC s (IRCState s) +getIRCState = ask + +-- | Get the connection state from an IRC state. +getConnectionState :: IRCState s -> STM ConnectionState +getConnectionState = readTVar . _connectionState + -- | Block until an action is successful or a timeout is reached. -timeout :: MonadIO m => NominalDiffTime -> IO Bool -> m () -timeout dt check = liftIO $ do +timeoutBlock :: MonadIO m => NominalDiffTime -> IO Bool -> m () +timeoutBlock dt check = liftIO $ do finish <- addUTCTime dt <$> getCurrentTime let wait = do now <- getCurrentTime cond <- check when (now < finish && not cond) wait wait + +-- | A simple wrapper around a TBMChan. As data is pushed into the +-- channel, the source will read it and pass it down the conduit +-- pipeline. When the channel is closed, the source will close also. +-- +-- If the channel fills up, the pipeline will stall until values are +-- read. +-- +-- From stm-conduit-3.0.0 (by Clark Gaebel ) +sourceTBMChan :: MonadIO m => TBMChan a -> ConduitM () a m () +sourceTBMChan ch = loop where + loop = do + a <- liftIO . atomically $ readTBMChan ch + case a of + Just x -> yield x >> loop + Nothing -> pure () diff --git a/Network/IRC/Client/Internal/Lens.hs b/Network/IRC/Client/Internal/Lens.hs new file mode 100644 --- /dev/null +++ b/Network/IRC/Client/Internal/Lens.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Network.IRC.Client.Internal.Lens +-- Copyright : (c) 2017 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : CPP, ImpredicativeTypes +-- +-- Types and functions for dealing with optics without depending on +-- the lens library. +-- +-- This module is NOT considered to form part of the public interface +-- of this library. +module Network.IRC.Client.Internal.Lens where + +import Control.Applicative (Const(..)) +import Control.Concurrent.STM (STM, TVar, atomically, readTVar, + readTVarIO, writeTVar) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Functor.Contravariant (Contravariant) +import Data.Functor.Identity (Identity(..)) +import Data.Monoid (First(..)) +import Data.Profunctor (Choice) + + +------------------------------------------------------------------------------- +-- * Internal lens synonyms + +-- | See @@. +type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t + +-- | A @@ 'Lens'. +type Lens' s a = Lens s s a a + +-- | See @@. +type Getter s a = forall f. (Contravariant f, Functor f) => (a -> f a) -> s -> f s + +-- | See @@. +type Getting r s a = (a -> Const r a) -> s -> Const r s + +-- | See @@. +type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) + +-- | A @@ 'Prism'. +type Prism' s a = Prism s s a a + + +------------------------------------------------------------------------------- +-- * Utilities + +-- | Get a value from a lens. +{-# INLINE get #-} +get :: Getting a s a -> s -> a +get lens = getConst . lens Const + +-- | Set a value in a lens. +{-# INLINE set #-} +set :: Lens' s a -> a -> s -> s +set lens a = runIdentity . lens (\_ -> Identity a) + +-- | Modify a value in a lens. +{-# INLINE modify #-} +modify :: Lens' s a -> (a -> a) -> s -> s +modify lens f s = let a = get lens s in set lens (f a) s + +-- | Read a value from a prism. +{-# INLINE preview #-} +preview :: Prism' s a -> s -> Maybe a +preview lens = getFirst . getConst . lens (Const . First . Just) + + +------------------------------------------------------------------------------- +-- ** STM + +-- | Atomically snapshot some shared state. +snapshot :: MonadIO m => Getting (TVar a) s (TVar a) -> s -> m a +snapshot lens = liftIO . readTVarIO . get lens + +-- | Atomically snapshot and modify some shared state. +snapshotModify :: MonadIO m => Lens' s (TVar a) -> (a -> STM (a, b)) -> s -> m b +snapshotModify lens f s = liftIO . atomically $ do + let avar = get lens s + a <- readTVar avar + (a', b) <- f a + writeTVar avar a' + pure b diff --git a/Network/IRC/Client/Internal/Types.hs b/Network/IRC/Client/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/Network/IRC/Client/Internal/Types.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Network.IRC.Client.Internal.Types +-- Copyright : (c) 2017 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses +-- +-- Internal types. Most of these are re-exported elsewhere as lenses. +-- +-- This module is NOT considered to form part of the public interface +-- of this library. +module Network.IRC.Client.Internal.Types where + +import Control.Applicative (Alternative) +import Control.Concurrent (ThreadId) +import Control.Concurrent.STM (TVar, atomically, readTVar, + readTVarIO, writeTVar) +import Control.Concurrent.STM.TBMChan (TBMChan) +import Control.Monad (MonadPlus) +import Control.Monad.Catch (Exception, MonadCatch, + MonadMask, MonadThrow, + SomeException) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (MonadReader, ReaderT, asks) +import Control.Monad.State (MonadState(..)) +import Data.ByteString (ByteString) +import Data.Conduit (ConduitM) +import qualified Data.Set as S +import Data.Text (Text) +import Data.Time.Clock (NominalDiffTime) +import Data.Void (Void) +import Network.IRC.Conduit (Event(..), Message, Source) + + +------------------------------------------------------------------------------- +-- * The IRC monad + +-- | The IRC monad. +newtype IRC s a = IRC { runIRC :: ReaderT (IRCState s) IO a } + deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadReader (IRCState s), MonadThrow, MonadCatch, MonadMask) + +instance MonadState s (IRC s) where + state f = do + tvar <- asks _userState + liftIO . atomically $ do + (a, s) <- f <$> readTVar tvar + writeTVar tvar s + pure a + get = do + tvar <- asks _userState + liftIO $ readTVarIO tvar + put s = do + tvar <- asks _userState + liftIO $ atomically (writeTVar tvar s) + +------------------------------------------------------------------------------- +-- * State + +-- | The state of an IRC session. +data IRCState s = IRCState + { _connectionConfig :: ConnectionConfig s + -- ^ Read-only connection configuration + , _userState :: TVar s + -- ^ Mutable user state + , _instanceConfig :: TVar (InstanceConfig s) + -- ^ Mutable instance configuration in STM + , _sendqueue :: TVar (TBMChan (Message ByteString)) + -- ^ Message send queue. + , _connectionState :: TVar ConnectionState + -- ^ State of the connection. + , _runningThreads :: TVar (S.Set ThreadId) + -- ^ Threads which will be killed when the client disconnects. + } + +-- | The static state of an IRC server connection. +data ConnectionConfig s = ConnectionConfig + { _func :: IO () -> ConduitM (Either ByteString (Event ByteString)) Void IO () -> ConduitM () (Message ByteString) IO () -> IO () + -- ^ Function to connect and start the conduits. + , _server :: ByteString + -- ^ The server host. + , _port :: Int + -- ^ The server port. + , _username :: Text + -- ^ Client username; sent to the server during the initial set-up. + , _realname :: Text + -- ^ Client realname; sent to the server during the initial set-up. + , _password :: Maybe Text + -- ^ Client password; sent to the server during the initial set-up. + , _flood :: NominalDiffTime + -- ^ The minimum time between two adjacent messages. + , _timeout :: NominalDiffTime + -- ^ The maximum time (in seconds) between received messages from + -- the server. If no messages arrive from the server for this + -- period, the client is sent a 'Timeout' exception and disconnects. + , _onconnect :: IRC s () + -- ^ Action to run after sending the @PASS@ and @USER@ commands to the + -- server. The default behaviour is to send the @NICK@ command. + , _ondisconnect :: Maybe SomeException -> IRC s () + -- ^ Action to run after disconnecting from the server, both by + -- local choice and by losing the connection. This is run after + -- tearing down the connection. If the connection terminated due to + -- an exception, it is given. The default behaviour is to reconnect + -- if a timeout, otherwise rethrow any exception. + , _logfunc :: Origin -> ByteString -> IO () + -- ^ Function to log messages sent to and received from the server. + } + +-- | The updateable state of an IRC connection. +data InstanceConfig s = InstanceConfig + { _nick :: Text + -- ^ Client nick + , _channels :: [Text] + -- ^ Current channels: this list both determines the channels to join on + -- connect, and is modified by the default event handlers when channels + -- are joined or parted. + , _version :: Text + -- ^ The version is sent in response to the CTCP \"VERSION\" request by + -- the default event handlers. + , _handlers :: [EventHandler s] + -- ^ The registered event handlers. The order in this list is the + -- order in which they are executed. + , _ignore :: [(Text, Maybe Text)] + -- ^ List of nicks (optionally restricted to channels) to ignore + -- messages from. 'Nothing' ignores globally. + } + +-- | The state of the connection. +data ConnectionState = Connected | Disconnecting | Disconnected + deriving (Bounded, Enum, Eq, Ord, Read, Show) + +-- | The origin of a message. +data Origin = FromServer | FromClient + deriving (Bounded, Enum, Eq, Ord, Read, Show) + + +------------------------------------------------------------------------------- +-- * Events + +-- | A function which handles an event. +data EventHandler s where + EventHandler + :: (Event Text -> Maybe b) + -> (Source Text -> b -> IRC s ()) + -> EventHandler s + + +------------------------------------------------------------------------------- +-- * Exceptions + +-- | Exception thrown to kill the client if the timeout elapses with +-- nothing received from the server. +data Timeout = Timeout + deriving (Bounded, Enum, Eq, Ord, Read, Show) + +instance Exception Timeout + +-- | Exception thrown to all managed threads when the client +-- disconnects. +data Disconnect = Disconnect + deriving (Bounded, Enum, Eq, Ord, Read, Show) + +instance Exception Disconnect diff --git a/Network/IRC/Client/Lens.hs b/Network/IRC/Client/Lens.hs new file mode 100644 --- /dev/null +++ b/Network/IRC/Client/Lens.hs @@ -0,0 +1,189 @@ +-- | +-- Module : Network.IRC.Client.Lens +-- Copyright : (c) 2017 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : CPP +-- +-- 'Lens'es and 'Prism's. +module Network.IRC.Client.Lens where + +import Control.Concurrent.STM (TVar) +import Control.Monad.Catch (SomeException) +import Data.ByteString (ByteString) +import Data.Profunctor (Choice(right'), + Profunctor(dimap)) +import Data.Text (Text) +import Data.Time (NominalDiffTime) + +import Network.IRC.Client.Internal.Lens +import Network.IRC.Client.Internal.Types + +{-# ANN module ("HLint: ignore Redundant lambda") #-} + +-- CPP seem to dislike the first ' on the RHS… +-- This style of CPP usage doesn't work with clang, which means won't work on Mac. +{- +#define PRIME() ' + +#define LENS(S,F,A) \ + {-# INLINE F #-}; \ + {-| PRIME()Lens' for '_/**/F'. -}; \ + F :: Lens' S A; \ + F = \ afb s -> (\ b -> s {_/**/F = b}) <$> afb (_/**/F s) + +#define GETTER(S,F,A) \ + {-# INLINE F #-}; \ + {-| PRIME()Getter' for '_/**/F'. -}; \ + F :: Getter S A; \ + F = \ afb s -> (\ b -> s {_/**/F = b}) <$> afb (_/**/F s) + +#define PRISM(S,C,ARG,TUP,A) \ + {-| PRIME()Prism' for 'C'. -}; \ + {-# INLINE _/**/C #-}; \ + _/**/C :: Prism' S A; \ + _/**/C = dimap (\ s -> case s of C ARG -> Right TUP; _ -> Left s) \ + (either pure $ fmap (\ TUP -> C ARG)) . right' + +-} + +------------------------------------------------------------------------------- +-- * Lenses for 'IRCState' + +{-# INLINE connectionConfig #-} +{-| 'Getter' for '_connectionConfig'. -} +connectionConfig :: Getter (IRCState s) (ConnectionConfig s) +connectionConfig = \ afb s -> (\ b -> s {_connectionConfig = b}) <$> afb (_connectionConfig s) + +{-# INLINE userState #-} +{-| 'Lens' for '_userState'. -} +userState :: Lens' (IRCState s) (TVar s) +userState = \ afb s -> (\ b -> s {_userState = b}) <$> afb (_userState s) + +{-# INLINE instanceConfig #-} +{-| 'Lens' for '_instanceConfig'. -} +instanceConfig :: Lens' (IRCState s) (TVar (InstanceConfig s)) +instanceConfig = \ afb s -> (\ b -> s {_instanceConfig = b}) <$> afb (_instanceConfig s) + +{-# INLINE connectionState #-} +{-| 'Lens' for '_connectionState'. -} +connectionState :: Lens' (IRCState s) (TVar ConnectionState) +connectionState = \ afb s -> (\ b -> s {_connectionState = b}) <$> afb (_connectionState s) + +------------------------------------------------------------------------------- +-- * Lenses for 'ConnectionConfig' + +{-# INLINE server #-} +{-| 'Getter' for '_server'. -} +server :: Getter (ConnectionConfig s) ByteString +server = \ afb s -> (\ b -> s {_server = b}) <$> afb (_server s) + +{-# INLINE port #-} +{-| 'Getter' for '_port'. -} +port :: Getter (ConnectionConfig s) Int +port = \ afb s -> (\ b -> s {_port = b}) <$> afb (_port s) + +{-# INLINE username #-} +{-| 'Lens' for '_username'. -} +username :: Lens' (ConnectionConfig s) Text +username = \ afb s -> (\ b -> s {_username = b}) <$> afb (_username s) + +{-# INLINE realname #-} +{-| 'Lens' for '_realname'. -} +realname :: Lens' (ConnectionConfig s) Text +realname = \ afb s -> (\ b -> s {_realname = b}) <$> afb (_realname s) + +{-# INLINE password #-} +{-| 'Lens' for '_password'. -} +password :: Lens' (ConnectionConfig s) (Maybe Text) +password = \ afb s -> (\ b -> s {_password = b}) <$> afb (_password s) + +{-# INLINE flood #-} +{-| 'Lens' for '_flood'. -} +flood :: Lens' (ConnectionConfig s) NominalDiffTime +flood = \ afb s -> (\ b -> s {_flood = b}) <$> afb (_flood s) + +{-# INLINE timeout #-} +{-| 'Lens' for '_timeout'. -} +timeout :: Lens' (ConnectionConfig s) NominalDiffTime +timeout = \ afb s -> (\ b -> s {_timeout = b}) <$> afb (_timeout s) + +{-# INLINE onconnect #-} +{-| 'Lens' for '_onconnect'. -} +onconnect :: Lens' (ConnectionConfig s) (IRC s ()) +onconnect = \ afb s -> (\ b -> s {_onconnect = b}) <$> afb (_onconnect s) + +{-# INLINE ondisconnect #-} +{-| 'Lens' for '_ondisconnect'. -} +ondisconnect :: Lens' (ConnectionConfig s) (Maybe SomeException -> IRC s ()) +ondisconnect = \ afb s -> (\ b -> s {_ondisconnect = b}) <$> afb (_ondisconnect s) + +{-# INLINE logfunc #-} +{-| 'Lens' for '_logfunc'. -} +logfunc :: Lens' (ConnectionConfig s) (Origin -> ByteString -> IO ()) +logfunc = \ afb s -> (\ b -> s {_logfunc = b}) <$> afb (_logfunc s) + +------------------------------------------------------------------------------- +-- * Lenses for 'InstanceConfig' + +{-# INLINE nick #-} +{-| 'Lens' for '_nick'. -} +nick :: Lens' (InstanceConfig s) Text +nick = \ afb s -> (\ b -> s {_nick = b}) <$> afb (_nick s) + +{-# INLINE channels #-} +{-| 'Lens' for '_channels'. -} +channels :: Lens' (InstanceConfig s) [Text] +channels = \ afb s -> (\ b -> s {_channels = b}) <$> afb (_channels s) + +{-# INLINE version #-} +{-| 'Lens' for '_version'. -} +version :: Lens' (InstanceConfig s) Text +version = \ afb s -> (\ b -> s {_version = b}) <$> afb (_version s) + +{-# INLINE handlers #-} +{-| 'Lens' for '_version'. -} +handlers :: Lens' (InstanceConfig s) [EventHandler s] +handlers = \ afb s -> (\ b -> s {_handlers = b}) <$> afb (_handlers s) + +{-# INLINE ignore #-} +{-| 'Lens' for '_ignore'. -} +ignore :: Lens' (InstanceConfig s) [(Text, Maybe Text)] +ignore = \ afb s -> (\ b -> s {_ignore = b}) <$> afb (_ignore s) + +------------------------------------------------------------------------------- +-- * Prisms for 'ConnectionState' + +{-| 'Prism' for 'Connected'. -} +{-# INLINE _Connected #-} +_Connected :: Prism' ConnectionState () +_Connected = dimap (\ s -> case s of Connected -> Right (); _ -> Left s) + (either pure $ fmap (\ () -> Connected)) . right' + +{-| 'Prism' for 'Disconnecting'. -} +{-# INLINE _Disconnecting #-} +_Disconnecting :: Prism' ConnectionState () +_Disconnecting = dimap (\ s -> case s of Disconnecting -> Right (); _ -> Left s) + (either pure $ fmap (\ () -> Disconnecting)) . right' + +{-| 'Prism' for 'Disconnected'. -} +{-# INLINE _Disconnected #-} +_Disconnected :: Prism' ConnectionState () +_Disconnected = dimap (\ s -> case s of Disconnected -> Right (); _ -> Left s) + (either pure $ fmap (\ () -> Disconnected)) . right' + +------------------------------------------------------------------------------- +-- * Prisms for 'Origin' + +{-| 'Prism' for 'FromServer'. -} +{-# INLINE _FromServer #-} +_FromServer :: Prism' Origin () +_FromServer = dimap (\ s -> case s of FromServer -> Right (); _ -> Left s) + (either pure $ fmap (\ () -> FromServer)) . right' + +{-| 'Prism' for 'FromClient'. -} +{-# INLINE _FromClient #-} +_FromClient :: Prism' Origin () +_FromClient = dimap (\ s -> case s of FromClient -> Right (); _ -> Left s) + (either pure $ fmap (\ () -> FromClient)) . right' diff --git a/Network/IRC/Client/Types.hs b/Network/IRC/Client/Types.hs deleted file mode 100644 --- a/Network/IRC/Client/Types.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - --- | --- Module : Network.IRC.Client.Types --- Copyright : (c) 2016 Michael Walker --- License : MIT --- Maintainer : Michael Walker --- Stability : experimental --- Portability : RankNTypes ---- --- Types for IRC clients. See also --- and --- . -module Network.IRC.Client.Types - ( module Network.IRC.Client.Types - - -- * Re-exported - , Event(..) - , Source(..) - , Message(..) - ) where - -import Control.Applicative ((<$>)) -import Control.Concurrent.STM (TVar, atomically, readTVar, newTVar, writeTVar) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Reader (ReaderT, ask) -import Data.ByteString (ByteString) -import Data.Conduit (Consumer, Producer) -import Data.Conduit.TMChan (TBMChan) -import Data.Text (Text) -import Data.Time.Clock (NominalDiffTime) -import Network.IRC.Conduit (Event(..), Message(..), Source(..), IrcEvent, IrcMessage) - --- *Type synonyms -type UnicodeEvent = Event Text -type UnicodeSource = Source Text -type UnicodeMessage = Message Text - --- *State - --- | The IRC monad. -type IRC a = StatefulIRC () a - --- | The IRC monad, with state. -type StatefulIRC s a = ReaderT (IRCState s) IO a - -data IRCState s = IRCState { _connectionConfig :: ConnectionConfig s - -- ^Read-only connection configuration - , _userState :: TVar s - -- ^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. -ircState :: StatefulIRC s (IRCState s) -ircState = ask - --- | Extract the connection configuration from an IRC state -getConnectionConfig :: IRCState s -> ConnectionConfig s -getConnectionConfig = _connectionConfig - --- | Extract the instance configuration from an IRC state -getInstanceConfig :: IRCState s -> TVar (InstanceConfig s) -getInstanceConfig = _instanceConfig - --- | 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 -getInstanceConfig' :: MonadIO m => IRCState s -> m (InstanceConfig s) -getInstanceConfig' = liftIO . atomically . readTVar . _instanceConfig - --- | Access the connection config -connectionConfig :: StatefulIRC s (ConnectionConfig s) -connectionConfig = _connectionConfig <$> ask - --- | Access the instance config TVar -instanceConfigTVar :: StatefulIRC s (TVar (InstanceConfig s)) -instanceConfigTVar = _instanceConfig <$> ask - --- | Access the instance config as it is right now. -instanceConfig :: StatefulIRC s (InstanceConfig s) -instanceConfig = instanceConfigTVar >>= liftIO . atomically . readTVar - --- | Overwrite the instance config, even if it has changed since we --- looked at it. -putInstanceConfig :: InstanceConfig s -> StatefulIRC s () -putInstanceConfig iconf = instanceConfigTVar >>= liftIO . atomically . flip writeTVar iconf - --- | Access the user state. -stateTVar :: StatefulIRC s (TVar s) -stateTVar = _userState <$> ask - --- | Access the user state as it is right now. -state :: StatefulIRC s s -state = stateTVar >>= liftIO . atomically . readTVar - --- | Set the user state. -putState :: s -> StatefulIRC s () -putState s = stateTVar >>= liftIO . atomically . flip writeTVar s - --- | The origin of a message. -data Origin = FromServer | FromClient - deriving (Eq, Read, Show) - --- | The static state of an IRC server connection. -data ConnectionConfig s = ConnectionConfig - { _func :: IO () -> Consumer (Either ByteString IrcEvent) IO () -> Producer IO IrcMessage -> IO () - -- ^ Function to connect and start the conduits. - , _sendqueue :: TBMChan IrcMessage - -- ^ Message send queue. - , _server :: ByteString - -- ^ The server host. - , _port :: Int - -- ^ The server port. - , _flood :: NominalDiffTime - -- ^ The minimum time between two adjacent messages. - , _onconnect :: StatefulIRC s () - -- ^ Action to run after successfully connecting to the server and - -- setting the nick. - , _ondisconnect :: StatefulIRC s () - -- ^ Action to run if the remote server closes the connection. - , _logfunc :: Origin -> ByteString -> IO () - -- ^ Function to log messages sent to and received from the server. - } - --- | The updateable state of an IRC connection. -data InstanceConfig s = InstanceConfig - { _nick :: Text - -- ^ Client nick - , _username :: Text - -- ^ Client username - , _realname :: Text - -- ^ Client realname - , _password :: Maybe Text - -- ^ Client password - , _channels :: [Text] - -- ^ Current channels - , _ctcpVer :: Text - -- ^ Response to CTCP VERSION - , _eventHandlers :: [EventHandler s] - -- ^ The registered event handlers - , _ignore :: [(Text, Maybe Text)] - -- ^ List of nicks (optionally restricted to channels) to ignore - -- messages from. No channel = global. - } - --- *Events - --- | Types of events which can be caught. -data EventType - = EEverything - -- ^ Match all events - | ENothing - -- ^ Match no events - | EPrivmsg | ENotice | ECTCP | ENick | EJoin | EPart | EQuit | EMode | ETopic | EInvite | EKick | EPing | ENumeric - deriving (Eq, Show) - --- | A function which handles an event. -data EventHandler s = EventHandler - { _description :: Text - -- ^ A description of the event handler. - , _matchType :: EventType - -- ^ Which type to be triggered by - , _eventFunc :: UnicodeEvent -> StatefulIRC s () - -- ^ The function to call. - } - --- | Get the type of an event. -eventType :: Event a -> EventType -eventType e = case _message e of - (Privmsg _ Right{}) -> EPrivmsg - (Privmsg _ Left{}) -> ECTCP - (Notice _ Right{}) -> ENotice - (Notice _ Left{}) -> ECTCP - - Nick{} -> ENick - Join{} -> EJoin - Part{} -> EPart - Quit{} -> EQuit - Mode{} -> EMode - Topic{} -> ETopic - Invite{} -> EInvite - Kick{} -> EKick - Ping{} -> EPing - Numeric{} -> ENumeric - - _ -> EEverything 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 @@ -7,79 +7,150 @@ -- Portability : portable -- -- Commonly-used utility functions for IRC clients. -module Network.IRC.Client.Utils where +module Network.IRC.Client.Utils + ( -- * Nicks + setNick -import Control.Concurrent.STM (TVar, STM, atomically, readTVar, writeTVar) -import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import Network.IRC.CTCP (toCTCP) -import Network.IRC.Client.Internal (send) -import Network.IRC.Client.Types + -- * Channels + , leaveChannel + , delChan -import qualified Data.Text as T + -- * Events + , addHandler + , reply + , replyTo + -- * CTCPs + , ctcp + , ctcpReply + + -- * Connection state + , isConnected + , isDisconnecting + , isDisconnected + , snapConnState + + -- * Concurrency + , fork + + -- * Lenses + , snapshot + , snapshotModify + , get + , set + , modify + ) where + +import Control.Concurrent (ThreadId, forkFinally, myThreadId) +import Control.Concurrent.STM (STM, TVar, atomically, modifyTVar) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import Network.IRC.Conduit (Event(..), Message(..), + Source(..)) +import Network.IRC.CTCP (toCTCP) + +import Network.IRC.Client.Internal +import Network.IRC.Client.Lens + +------------------------------------------------------------------------------- +-- Nicks + -- | Update the nick in the instance configuration and also send an -- update message to the server. This doesn't attempt to resolve nick -- collisions, that's up to the event handlers. -setNick :: Text -> StatefulIRC s () +setNick :: Text -> IRC s () setNick new = do - tvarI <- instanceConfigTVar + tvarI <- get instanceConfig <$> getIRCState + liftIO . atomically $ + modifyTVar tvarI (set nick new) + send $ Nick new - liftIO . atomically $ do - iconf <- readTVar tvarI - writeTVar tvarI iconf { _nick = new } - send $ Nick new +------------------------------------------------------------------------------- +-- Channels -- | Update the channel list in the instance configuration and also -- part the channel. -leaveChannel :: Text -> Maybe Text -> StatefulIRC s () +leaveChannel :: Text -> Maybe Text -> IRC s () leaveChannel chan reason = do - tvarI <- instanceConfigTVar + tvarI <- get instanceConfig <$> getIRCState liftIO . atomically $ delChan tvarI chan - send $ Part chan reason -- | Remove a channel from the list without sending a part command (be -- careful not to let the channel list get out of sync with the -- real-world state if you use it for anything!) delChan :: TVar (InstanceConfig s) -> Text -> STM () -delChan tvarI chan = do - iconf <- readTVar tvarI - writeTVar tvarI iconf { _channels = filter (/=chan) $ _channels iconf } +delChan tvarI chan = + modifyTVar tvarI (modify channels (filter (/=chan))) + +------------------------------------------------------------------------------- +-- Events + -- | Add an event handler -addHandler :: EventHandler s -> StatefulIRC s () +addHandler :: EventHandler s -> IRC s () addHandler handler = do - tvarI <- instanceConfigTVar + tvarI <- get instanceConfig <$> getIRCState + liftIO . atomically $ + modifyTVar tvarI (modify handlers (handler:)) - liftIO . atomically $ do - iconf <- readTVar tvarI - writeTVar tvarI iconf { _eventHandlers = handler : _eventHandlers iconf } +-- | Send a message to the source of an event. +reply :: Event Text -> Text -> IRC s () +reply = replyTo . _source -- | Send a message to the source of an event. -reply :: UnicodeEvent -> Text -> StatefulIRC s () -reply ev txt = case _source ev of - Channel c _ -> mapM_ (send . Privmsg c . Right) $ T.lines txt - User n -> mapM_ (send . Privmsg n . Right) $ T.lines txt - _ -> return () +replyTo :: Source Text -> Text -> IRC s () +replyTo (Channel c _) = mapM_ (send . Privmsg c . Right) . T.lines +replyTo (User n) = mapM_ (send . Privmsg n . Right) . T.lines +replyTo _ = const $ pure () + +------------------------------------------------------------------------------- +-- CTCPs + -- | Construct a @PRIVMSG@ containing a CTCP -ctcp :: Text -> Text -> [Text] -> UnicodeMessage +ctcp :: Text -> Text -> [Text] -> Message Text ctcp t command args = Privmsg t . Left $ toCTCP command args -- | Construct a @NOTICE@ containing a CTCP -ctcpReply :: Text -> Text -> [Text] -> UnicodeMessage +ctcpReply :: Text -> Text -> [Text] -> Message Text ctcpReply t command args = Notice t . Left $ toCTCP command args + +------------------------------------------------------------------------------- +-- Connection state + -- | Check if the client is connected. -isConnected :: StatefulIRC s Bool -isConnected = (==Connected) <$> (getConnState =<< ircState) +isConnected :: IRC s Bool +isConnected = (==Connected) <$> snapConnState -- | Check if the client is in the process of disconnecting. -isDisconnecting :: StatefulIRC s Bool -isDisconnecting = (==Disconnecting) <$> (getConnState =<< ircState) +isDisconnecting :: IRC s Bool +isDisconnecting = (==Disconnecting) <$> snapConnState -- | Check if the client is disconnected -isDisconnected :: StatefulIRC s Bool -isDisconnected = (==Disconnected) <$> (getConnState =<< ircState) +isDisconnected :: IRC s Bool +isDisconnected = (==Disconnected) <$> snapConnState + +-- | Snapshot the connection state. +snapConnState :: IRC s ConnectionState +snapConnState = liftIO . atomically . getConnectionState =<< getIRCState + + +------------------------------------------------------------------------------- +-- Concurrency + +-- | Fork a thread which will be thrown a 'Disconnect' exception when +-- the client disconnects. +fork :: IRC s () -> IRC s ThreadId +fork ma = do + s <- getIRCState + liftIO $ do + tid <- forkFinally (runIRCAction ma s) $ \_ -> do + tid <- myThreadId + atomically $ modifyTVar (_runningThreads s) (S.delete tid) + atomically $ modifyTVar (_runningThreads s) (S.insert tid) + pure tid diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain 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.4.4 +version: 1.1.2.3 -- A short (one-line) description of the package. synopsis: An IRC client library. @@ -68,14 +68,17 @@ library -- Modules exported by the library. exposed-modules: Network.IRC.Client - , Network.IRC.Client.Handlers - , Network.IRC.Client.Types - , Network.IRC.Client.Utils + , Network.IRC.Client.Events , Network.IRC.Client.Internal - + , Network.IRC.Client.Internal.Lens + , Network.IRC.Client.Internal.Types + , Network.IRC.Client.Lens + , Network.IRC.Client.Utils + -- Modules included in this library but not exported. - -- other-modules: - + other-modules: + Paths_irc_client + -- Compile with -Wall by default ghc-options: -Wall @@ -84,18 +87,23 @@ -- Other library packages from which modules are imported. build-depends: base >=4.7 && <5 - , bytestring >=0.10 && <0.11 - , conduit >=1.2 && <1.3 - , connection >=0.2 && <0.3 - , irc-conduit >=0.2.1 && <0.3 + , bytestring >=0.10 && <0.12 + , containers >=0.1 && <1 + , conduit >=1.2.8 && <1.4 + , connection >=0.2 && <0.4 + , contravariant >=0.1 && <1.6 + , exceptions >=0.6 && <0.11 + , irc-conduit >=0.3 && <0.4 , irc-ctcp >=0.1.2 && <0.2 - , network-conduit-tls >=1.1 && <1.3 + , mtl >=2.1 && <2.3 + , network-conduit-tls >=1.1 && <1.4 , old-locale >=1.0 && <1.1 - , stm >=2.4 && <2.5 - , stm-conduit >=2.5 && <3.1 + , profunctors >=5 && <6 + , stm >=2.4 && <2.6 + , stm-chans >=2.0 && <3.1 , text >=1.1 && <1.3 - , time >=1.4 && <1.9 - , tls >=1.3 && <1.5 + , time >=1.4 && <2 + , tls >=1.3 && <1.6 , transformers >=0.3 && <0.6 , x509 >=1.6 && <1.8 , x509-store >=1.6 && <1.7 @@ -106,6 +114,8 @@ -- Base language which the package is written in. default-language: Haskell2010 + + ghc-options: -Wall source-repository head type: git @@ -114,4 +124,4 @@ source-repository this type: git location: https://github.com/barrucadu/irc-client.git - tag: 0.4.4.4 + tag: 1.1.2.3