irc-client 0.4.4.4 → 1.1.2.3
raw patch · 11 files changed
Files
- Network/IRC/Client.hs +233/−169
- Network/IRC/Client/Events.hs +329/−0
- Network/IRC/Client/Handlers.hs +0/−250
- Network/IRC/Client/Internal.hs +213/−110
- Network/IRC/Client/Internal/Lens.hs +88/−0
- Network/IRC/Client/Internal/Types.hs +168/−0
- Network/IRC/Client/Lens.hs +189/−0
- Network/IRC/Client/Types.hs +0/−215
- Network/IRC/Client/Utils.hs +109/−38
- Setup.hs +1/−1
- irc-client.cabal +27/−17
Network/IRC/Client.hs view
@@ -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 @<http://hackage.haskell.org/package/irc-conduit/docs/Network-IRC-Conduit.html#t:defaultTLSConfig Network.IRC.Conduit.defaultTLSConfig>@.+ | 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 @<http://hackage.haskell.org/package/irc-conduit/docs/Network-IRC-Conduit.html#t:defaultTLSConfig Network.IRC.Conduit.defaultTLSConfig>@,+ -- 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
+ Network/IRC/Client/Events.hs view
@@ -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 <mike@barrucadu.co.uk>+-- 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 @<https://tools.ietf.org/html/rfc2812#section-5+-- RFC 2812>@ 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
− Network/IRC/Client/Handlers.hs
@@ -1,250 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}---- |--- Module : Network.IRC.Client.Handlers--- Copyright : (c) 2016 Michael Walker--- License : MIT--- Maintainer : Michael Walker <mike@barrucadu.co.uk>--- 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
Network/IRC/Client/Internal.hs view
@@ -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 <mike@barrucadu.co.uk> -- 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" ["<password redacted>"]+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 <cg.wowus.cg@gmail.com>)+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 ()
+ Network/IRC/Client/Internal/Lens.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE RankNTypes #-}++-- |+-- Module : Network.IRC.Client.Internal.Lens+-- Copyright : (c) 2017 Michael Walker+-- License : MIT+-- Maintainer : Michael Walker <mike@barrucadu.co.uk>+-- 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 @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Lens.html#t:Lens Control.Lens.Lens.Lens>@.+type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t++-- | A @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Type.html#t:Simple Simple>@ 'Lens'.+type Lens' s a = Lens s s a a++-- | See @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Getter.html#t:Getter Control.Lens.Getter.Getter>@.+type Getter s a = forall f. (Contravariant f, Functor f) => (a -> f a) -> s -> f s++-- | See @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Getter.html#t:Getting Control.Lens.Getter.Getting>@.+type Getting r s a = (a -> Const r a) -> s -> Const r s++-- | See @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Prism.html#t:Prism Control.Lens.Prism.Prism>@.+type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)++-- | A @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Type.html#t:Simple Simple>@ '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
+ Network/IRC/Client/Internal/Types.hs view
@@ -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 <mike@barrucadu.co.uk>+-- 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
+ Network/IRC/Client/Lens.hs view
@@ -0,0 +1,189 @@+-- |+-- Module : Network.IRC.Client.Lens+-- Copyright : (c) 2017 Michael Walker+-- License : MIT+-- Maintainer : Michael Walker <mike@barrucadu.co.uk>+-- 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'
− Network/IRC/Client/Types.hs
@@ -1,215 +0,0 @@-{-# LANGUAGE RankNTypes #-}---- |--- Module : Network.IRC.Client.Types--- Copyright : (c) 2016 Michael Walker--- License : MIT--- Maintainer : Michael Walker <mike@barrucadu.co.uk>--- Stability : experimental--- Portability : RankNTypes------- Types for IRC clients. See also--- <http://hackage.haskell.org/package/irc-conduit/docs/Network-IRC-Conduit.html Network.IRC.Conduit> and--- <http://hackage.haskell.org/package/irc-ctcp-0.1.2.1/docs/Network-IRC-CTCP.html Network.IRC.CTCP>.-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
Network/IRC/Client/Utils.hs view
@@ -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
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple+import Distribution.Simple main = defaultMain
irc-client.cabal view
@@ -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