irc-client 0.4.4.4 → 1.0.0.0

raw patch · 11 files changed

+1270/−781 lines, 11 filesdep +containersdep +contravariantdep +exceptionsdep ~irc-conduitdep ~timedep ~tlsnew-component:exe:irc-clientPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, contravariant, exceptions, lens, mtl, profunctors

Dependency ranges changed: irc-conduit, time, tls

API changes (from Hackage documentation)

Files

• Main.hs +21/−0
• Network/IRC/Client.hs +227/−163
• Network/IRC/Client/Events.hs +326/−0
• Network/IRC/Client/Handlers.hs +0/−250
• Network/IRC/Client/Internal.hs +176/−107
• Network/IRC/Client/Internal/Lens.hs +87/−0
• Network/IRC/Client/Internal/Types.hs +163/−0
• Network/IRC/Client/Lens.hs +95/−0
• Network/IRC/Client/Types.hs +0/−215
• Network/IRC/Client/Utils.hs +107/−37
• irc-client.cabal +68/−9

@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Concurrent+import Control.Lens+import Network.IRC.Client++main :: IO ()+main = do+  let conn = tlsConnection (WithDefaultConfig "irc.freenode.net" 6697)+               & logfunc .~ stdoutLogger+  let cfg  = defaultInstanceConfig "nickname"+               & channels .~ ["#channel"]+               & handlers %~ (yourHandlers++)+  ircstate <- newIRCState conn cfg initialState+  forkIO (runClientWith ircstate)+  -- you can now use runIRCAction with the ircstate value to interact with the client+  -- eg:+  runIRCAction disconnect ircstate++yourHandlers = []+initialState = ()

@@ -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 Control.Concurrent.STM (newTVarIO)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.ByteString (ByteString) import qualified Data.Conduit.Network.TLS as TLS-import Data.Text                  (Text)-import Data.Time.Clock            (NominalDiffTime)+import Data.Conduit.TMChan (newTBMChanIO)+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 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 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

@@ -0,0 +1,326 @@+{-# 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+  , 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, readTVar, modifyTVar)+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.CTCP (fromCTCP)+import Network.IRC.Conduit.Lens++#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

@@ -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

@@ -1,6 +1,7 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}  -- |@@ -9,7 +10,7 @@ -- License     : MIT -- Maintainer  : Michael Walker <mike@barrucadu.co.uk> -- Stability   : experimental--- Portability : CPP, OverloadedStrings, RankNTypes, ScopedTypeVariables+-- Portability : CPP, LambdaCase, OverloadedStrings, RankNTypes, 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 +18,52 @@ -- -- 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.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)+import Data.Conduit (Producer, Conduit, Consumer, (=$=), ($=), (=$), await, awaitForever, toProducer, yield)+import Data.Conduit.TMChan (closeTBMChan, isClosedTBMChan, isEmptyTBMChan, sourceTBMChan, writeTBMChan, newTBMChan)+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 Network.IRC.Conduit (Event(..), Message(..), Source(..), floodProtector, rawMessage, toByteString)  #if MIN_VERSION_time(1,5,0) 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 () -> Consumer (Either ByteString (Event ByteString)) IO () -> Producer IO (Message ByteString) -> 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,66 +71,77 @@   -- ^ 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 = toProducer $ sourceTBMChan squeue+                          $= antiflood+                          $= logConduit (_logfunc cconf FromClient . toByteString)+  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 delay = round time+  let timeoutThread = do+        now <- getCurrentTime+        prior <- readIORef lastReceived+        if diffUTCTime now prior >= time+          then throwTo mainTId Timeout+          else threadDelay delay >> 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@@ -124,25 +149,32 @@   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 -> Consumer (Event ByteString) 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,10 +183,6 @@       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 logf = awaitForever $ \x -> do@@ -191,56 +219,97 @@ noopLogger :: a -> b -> IO () noopLogger _ _ = return () ++------------------------------------------------------------------------------- -- * 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

@@ -0,0 +1,87 @@+{-# 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 (TVar, STM, atomically, readTVar, 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 . atomically . readTVar . 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

@@ -0,0 +1,163 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}++-- |+-- 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, RankNTypes+--+-- 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.Concurrent (ThreadId)+import Control.Concurrent.STM (TVar, atomically, readTVar, writeTVar)+import Control.Monad.Catch (Exception, MonadThrow, MonadCatch, MonadMask, 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 (Consumer, Producer)+import Data.Conduit.TMChan (TBMChan)+import qualified Data.Set as S+import Data.Text (Text)+import Data.Time.Clock (NominalDiffTime)+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, Monad, 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 $ atomically (readTVar 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 () -> Consumer (Either ByteString (Event ByteString)) IO () -> Producer IO (Message ByteString) -> 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 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

@@ -0,0 +1,95 @@+{-# LANGUAGE CPP #-}++-- |+-- 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…+#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'++GETTER((IRCState s),connectionConfig,(ConnectionConfig s))+LENS((IRCState s),userState,(TVar s))+LENS((IRCState s),instanceConfig,(TVar (InstanceConfig s)))+LENS((IRCState s),connectionState,(TVar ConnectionState))+++-------------------------------------------------------------------------------+-- * Lenses for 'ConnectionConfig'++GETTER((ConnectionConfig s),server,ByteString)+GETTER((ConnectionConfig s),port,Int)+LENS((ConnectionConfig s),username,Text)+LENS((ConnectionConfig s),realname,Text)+LENS((ConnectionConfig s),password,(Maybe Text))+LENS((ConnectionConfig s),flood,NominalDiffTime)+LENS((ConnectionConfig s),timeout,NominalDiffTime)+LENS((ConnectionConfig s),onconnect,(IRC s ()))+LENS((ConnectionConfig s),ondisconnect,(Maybe SomeException -> IRC s ()))+LENS((ConnectionConfig s),logfunc,(Origin -> ByteString -> IO ()))+++-------------------------------------------------------------------------------+-- * Lenses for 'InstanceConfig'++LENS((InstanceConfig s),nick,Text)+LENS((InstanceConfig s),channels,[Text])+LENS((InstanceConfig s),version,Text)+LENS((InstanceConfig s),handlers,[EventHandler s])+LENS((InstanceConfig s),ignore,[(Text, Maybe Text)])+++-------------------------------------------------------------------------------+-- * Prisms for 'ConnectionState'++PRISM(ConnectionState,Connected,,(),())+PRISM(ConnectionState,Disconnecting,,(),())+PRISM(ConnectionState,Disconnected,,(),())+++-------------------------------------------------------------------------------+-- * Prisms for 'Origin'++PRISM(Origin,FromServer,,(),())+PRISM(Origin,FromClient,,(),())

@@ -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

@@ -7,79 +7,149 @@ -- 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 +    -- * 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, myThreadId, forkFinally)+import Control.Concurrent.STM (TVar, STM, 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

@@ -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.0.0.0  -- 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   @@ -85,12 +88,17 @@   -- Other library packages from which modules are imported.   build-depends:       base                >=4.7   && <5                      , bytestring          >=0.10  && <0.11+                     , containers          >=0.1   && <1                      , conduit             >=1.2   && <1.3                      , connection          >=0.2   && <0.3-                     , irc-conduit         >=0.2.1 && <0.3+                     , contravariant       >=0.1   && <1.5+                     , exceptions          >=0.6   && <0.9+                     , irc-conduit         >=0.2.2 && <0.3                      , irc-ctcp            >=0.1.2 && <0.2+                     , mtl                 >=2.1   && <2.3                      , network-conduit-tls >=1.1   && <1.3                      , old-locale          >=1.0   && <1.1+                     , profunctors         >=5     && <6                      , stm                 >=2.4   && <2.5                      , stm-conduit         >=2.5   && <3.1                      , text                >=1.1   && <1.3@@ -107,6 +115,57 @@   -- Base language which the package is written in.   default-language:    Haskell2010   +executable irc-client+  main-is: Main.hs+  -- Modules exported by the library.+  other-modules:     Network.IRC.Client+                     , 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:+    Paths_irc_client++  -- Compile with -Wall by default+  ghc-options:         -Wall+  +  -- LANGUAGE extensions used by modules in this package.+  -- other-extensions:    +  +  -- Other library packages from which modules are imported.+  build-depends:       base                >=4.7   && <5+                     , bytestring          >=0.10  && <0.11+                     , containers          >=0.1   && <1+                     , conduit             >=1.2   && <1.3+                     , connection          >=0.2   && <0.3+                     , contravariant       >=0.1   && <1.5+                     , exceptions          >=0.6   && <0.9+                     , irc-conduit         >=0.2.2 && <0.3+                     , irc-ctcp            >=0.1.2 && <0.2+                     , mtl                 >=2.1   && <2.3+                     , network-conduit-tls >=1.1   && <1.3+                     , old-locale          >=1.0   && <1.1+                     , profunctors         >=5     && <6+                     , stm                 >=2.4   && <2.5+                     , stm-conduit         >=2.5   && <3.1+                     , text                >=1.1   && <1.3+                     , time                >=1.4   && <1.7+                     , tls                 >=1.3   && <1.4+                     , transformers        >=0.3   && <0.6+                     , x509                >=1.6   && <1.8+                     , x509-store          >=1.6   && <1.7+                     , x509-validation     >=1.6   && <1.7, lens+  +  -- Directories containing source files.+  -- hs-source-dirs:      +  +  -- Base language which the package is written in.+  default-language:    Haskell2010+   source-repository head   type:     git   location: https://github.com/barrucadu/irc-client.git@@ -114,4 +173,4 @@ source-repository this   type:     git   location: https://github.com/barrucadu/irc-client.git-  tag:      0.4.4.4+  tag:      1.0.0.0