diff options
Diffstat (limited to 'vendor/irc-client')
| -rw-r--r-- | vendor/irc-client/LICENSE | 20 | ||||
| -rw-r--r-- | vendor/irc-client/Network/IRC/Client.hs | 296 | ||||
| -rw-r--r-- | vendor/irc-client/Network/IRC/Client/Events.hs | 328 | ||||
| -rw-r--r-- | vendor/irc-client/Network/IRC/Client/Internal.hs | 358 | ||||
| -rw-r--r-- | vendor/irc-client/Network/IRC/Client/Internal/Lens.hs | 88 | ||||
| -rw-r--r-- | vendor/irc-client/Network/IRC/Client/Internal/Types.hs | 168 | ||||
| -rw-r--r-- | vendor/irc-client/Network/IRC/Client/Lens.hs | 189 | ||||
| -rw-r--r-- | vendor/irc-client/Network/IRC/Client/Utils.hs | 156 | ||||
| -rw-r--r-- | vendor/irc-client/Setup.hs | 2 | ||||
| -rw-r--r-- | vendor/irc-client/irc-client.cabal | 127 |
10 files changed, 1732 insertions, 0 deletions
diff --git a/vendor/irc-client/LICENSE b/vendor/irc-client/LICENSE new file mode 100644 index 0000000..61d9d0c --- /dev/null +++ b/vendor/irc-client/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015, Michael Walker <mike@barrucadu.co.uk> + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/vendor/irc-client/Network/IRC/Client.hs b/vendor/irc-client/Network/IRC/Client.hs new file mode 100644 index 0000000..abae449 --- /dev/null +++ b/vendor/irc-client/Network/IRC/Client.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.IRC.Client +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker <mike@barrucadu.co.uk> +-- Stability : experimental +-- Portability : OverloadedStrings +-- +-- A simple IRC client library. Typical usage will be of this form: +-- +-- > run :: ByteString -> Int -> Text -> IO () +-- > run host port nick = do +-- > 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 + ( -- * Configuration + + -- | 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 + + -- ** 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 + + -- ** From event handlers + + , 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.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 + +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 + +import qualified Paths_irc_client as Paths + + +------------------------------------------------------------------------------- +-- Configuration + +-- | Connect to a server without TLS. +plainConnection + :: ByteString + -- ^ The hostname + -> Int + -- ^ The port + -> ConnectionConfig s +plainConnection host port_ = + setupInternal (C.ircClient port_ host) defaultOnConnect defaultOnDisconnect noopLogger 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. +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 +tlsConnection (WithVerifier host port_ verifier) = + setupInternal (C.ircTLSClient' cfg) defaultOnConnect defaultOnDisconnect noopLogger host port_ + where + cfg = + 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 + cHooks = TLS.clientHooks cTLSSettings + in cfg0 { TLS.tlsClientTLSSettings = TLS.TLSSettings cTLSSettings + { TLS.clientHooks = cHooks + { TLS.onServerCertificate = verifier } + } + } + +-- | 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 = [] + } + + +------------------------------------------------------------------------------- +-- Execution + +-- | 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 + +-- | 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 + + +------------------------------------------------------------------------------- +-- State + +-- | Construct a new IRC state +newIRCState :: MonadIO m + => ConnectionConfig s + -> InstanceConfig s + -> s + -- ^ The initial value for the user state. + -> m (IRCState s) +newIRCState cconf iconf ustate = liftIO $ IRCState cconf + <$> newTVarIO ustate + <*> newTVarIO iconf + <*> (newTVarIO =<< newTBMChanIO 16) + <*> newTVarIO Disconnected + <*> newTVarIO S.empty diff --git a/vendor/irc-client/Network/IRC/Client/Events.hs b/vendor/irc-client/Network/IRC/Client/Events.hs new file mode 100644 index 0000000..c55e055 --- /dev/null +++ b/vendor/irc-client/Network/IRC/Client/Events.hs @@ -0,0 +1,328 @@ +{-# 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.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 diff --git a/vendor/irc-client/Network/IRC/Client/Internal.hs b/vendor/irc-client/Network/IRC/Client/Internal.hs new file mode 100644 index 0000000..c56bd57 --- /dev/null +++ b/vendor/irc-client/Network/IRC/Client/Internal.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Network.IRC.Client.Internal +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker <mike@barrucadu.co.uk> +-- Stability : experimental +-- 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 +-- reasonably possible. +-- +-- This module is NOT considered to form part of the public interface +-- of this library. +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.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', decodeLatin1, + 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) +#else +import System.Locale (defaultTimeLocale) +#endif + +import Network.IRC.Client.Internal.Lens +import Network.IRC.Client.Internal.Types +import Network.IRC.Client.Lens + + +------------------------------------------------------------------------------- +-- * 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. + -> IRC s () + -- ^ Connect handler + -> (Maybe SomeException -> IRC s ()) + -- ^ Disconnect handler + -> (Origin -> ByteString -> IO ()) + -- ^ Logging function + -> ByteString + -- ^ Server hostname + -> Int + -- ^ Server port + -> 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 + } + + +------------------------------------------------------------------------------- +-- * Event loop + +-- | The event loop. +runner :: IRC s () +runner = do + state <- getIRCState + let cconf = _connectionConfig state + + -- Set the real- and user-name + let theUser = get username cconf + let theReal = get realname cconf + let thePass = get password cconf + + -- Initialise the IRC session + 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 cconf + + -- Run the event loop, and call the disconnect handler if the remote + -- end closes the socket. + antiflood <- liftIO $ floodProtector (_flood cconf) + + -- An IORef to keep track of the time of the last received message, to allow a local timeout. + lastReceived <- liftIO $ newIORef =<< getCurrentTime + + squeue <- liftIO . readTVarIO $ _sendqueue 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 cconf initialise sink source >> killThread timeoutTId >> pure Nothing) + (pure . Just) + + disconnect + _ondisconnect cconf exc + +-- | Forget failed decodings. +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. +eventSink :: MonadIO m => IORef UTCTime -> IRCState s -> ConduitM (Event ByteString) o m () +eventSink lastReceived ircstate = go where + go = await >>= maybe (return ()) (\event -> do + -- Record the current time. + now <- liftIO getCurrentTime + liftIO $ writeIORef lastReceived now + + -- Handle the event. + let event' = decodeEncodingIRC <$> event + ignored <- isIgnored ircstate event' + 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 <- liftIO . atomically $ (==Disconnected) <$> getConnectionState ircstate + unless disconnected go) + + decodeEncodingIRC :: ByteString -> Text + decodeEncodingIRC bs = + case decodeUtf8' bs of + Left _ -> decodeLatin1 bs + Right t -> t + +-- | Check if an event is ignored or not. +isIgnored :: MonadIO m => IRCState s -> Event Text -> m Bool +isIgnored ircstate ev = do + iconf <- liftIO . readTVarIO . _instanceConfig $ ircstate + let ignoreList = _ignore iconf + + return $ + case _source ev of + User n -> (n, Nothing) `elem` ignoreList + Channel c n -> ((n, Nothing) `elem` ignoreList) || ((n, Just c) `elem` ignoreList) + Server _ -> False + +-- |A conduit which logs everything which goes through it. +logConduit :: MonadIO m => (a -> IO ()) -> ConduitM a a m () +logConduit logf = awaitForever $ \x -> do + -- Call the logging function + liftIO $ logf x + + -- And pass the message on + yield x + +-- | Print messages to stdout, with the current time. +stdoutLogger :: Origin -> ByteString -> IO () +stdoutLogger origin x = do + now <- getCurrentTime + + putStrLn $ unwords + [ formatTime defaultTimeLocale "%c" now + , if origin == FromServer then "<---" else "--->" + , init . tail $ show x + ] + +-- | Append messages to a file, with the current time. +fileLogger :: FilePath -> Origin -> ByteString -> IO () +fileLogger fp origin x = do + now <- getCurrentTime + + appendFile fp $ unwords + [ formatTime defaultTimeLocale "%c" now + , if origin == FromServer then "--->" else "<---" + , init . tail $ show x + , "\n" + ] + +-- | Do no logging. +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 :: Message Text -> IRC s () +send = sendBS . fmap encodeUtf8 + +-- | Send a message, using TLS if enabled. This blocks if messages are +-- sent too rapidly. +sendBS :: Message ByteString -> IRC s () +sendBS msg = do + 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 :: IRC s () +disconnect = do + s <- getIRCState + + 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. + timeoutBlock 60 . atomically $ do + queue <- readTVar (_sendqueue s) + (||) <$> isEmptyTBMChan queue <*> isClosedTBMChan queue + + -- Close the chan, which closes the sending conduit, and set + -- the state to @Disconnected@. + atomically $ do + closeTBMChan =<< readTVar (_sendqueue s) + writeTVar (_connectionState s) Disconnected + + -- 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 + + -- If already disconnected, or disconnecting, do nothing. + _ -> pure () + +-- | 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. +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 () diff --git a/vendor/irc-client/Network/IRC/Client/Internal/Lens.hs b/vendor/irc-client/Network/IRC/Client/Internal/Lens.hs new file mode 100644 index 0000000..783aa63 --- /dev/null +++ b/vendor/irc-client/Network/IRC/Client/Internal/Lens.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Network.IRC.Client.Internal.Lens +-- Copyright : (c) 2017 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker <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 diff --git a/vendor/irc-client/Network/IRC/Client/Internal/Types.hs b/vendor/irc-client/Network/IRC/Client/Internal/Types.hs new file mode 100644 index 0000000..73fbf14 --- /dev/null +++ b/vendor/irc-client/Network/IRC/Client/Internal/Types.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Network.IRC.Client.Internal.Types +-- Copyright : (c) 2017 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker <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 diff --git a/vendor/irc-client/Network/IRC/Client/Lens.hs b/vendor/irc-client/Network/IRC/Client/Lens.hs new file mode 100644 index 0000000..0afc3f5 --- /dev/null +++ b/vendor/irc-client/Network/IRC/Client/Lens.hs @@ -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' diff --git a/vendor/irc-client/Network/IRC/Client/Utils.hs b/vendor/irc-client/Network/IRC/Client/Utils.hs new file mode 100644 index 0000000..f9833c7 --- /dev/null +++ b/vendor/irc-client/Network/IRC/Client/Utils.hs @@ -0,0 +1,156 @@ +-- | +-- Module : Network.IRC.Client.Utils +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker <mike@barrucadu.co.uk> +-- Stability : experimental +-- Portability : portable +-- +-- Commonly-used utility functions for IRC clients. +module Network.IRC.Client.Utils + ( -- * Nicks + setNick + + -- * 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, 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 -> IRC s () +setNick new = do + tvarI <- get instanceConfig <$> getIRCState + liftIO . atomically $ + modifyTVar tvarI (set nick new) + send $ Nick new + + +------------------------------------------------------------------------------- +-- Channels + +-- | Update the channel list in the instance configuration and also +-- part the channel. +leaveChannel :: Text -> Maybe Text -> IRC s () +leaveChannel chan reason = do + 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 = + modifyTVar tvarI (modify channels (filter (/=chan))) + + +------------------------------------------------------------------------------- +-- Events + +-- | Add an event handler +addHandler :: EventHandler s -> IRC s () +addHandler handler = do + tvarI <- get instanceConfig <$> getIRCState + liftIO . atomically $ + modifyTVar tvarI (modify handlers (handler:)) + +-- | 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. +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] -> Message Text +ctcp t command args = Privmsg t . Left $ toCTCP command args + +-- | Construct a @NOTICE@ containing a CTCP +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 :: IRC s Bool +isConnected = (==Connected) <$> snapConnState + +-- | Check if the client is in the process of disconnecting. +isDisconnecting :: IRC s Bool +isDisconnecting = (==Disconnecting) <$> snapConnState + +-- | Check if the client is disconnected +isDisconnected :: IRC s Bool +isDisconnected = (==Disconnected) <$> snapConnState + +-- | Snapshot the connection state. +snapConnState :: IRC s ConnectionState +snapConnState = liftIO . atomically . getConnectionState =<< getIRCState + + +------------------------------------------------------------------------------- +-- Concurrency + +-- | Fork a thread which will be thrown a 'Disconnect' exception when +-- the client disconnects. +fork :: IRC s () -> IRC s ThreadId +fork ma = do + s <- getIRCState + liftIO $ do + tid <- forkFinally (runIRCAction ma s) $ \_ -> do + tid <- myThreadId + atomically $ modifyTVar (_runningThreads s) (S.delete tid) + atomically $ modifyTVar (_runningThreads s) (S.insert tid) + pure tid diff --git a/vendor/irc-client/Setup.hs b/vendor/irc-client/Setup.hs new file mode 100644 index 0000000..4467109 --- /dev/null +++ b/vendor/irc-client/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/vendor/irc-client/irc-client.cabal b/vendor/irc-client/irc-client.cabal new file mode 100644 index 0000000..490665b --- /dev/null +++ b/vendor/irc-client/irc-client.cabal @@ -0,0 +1,127 @@ +-- Initial idte.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: irc-client + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 1.1.2.3 + +-- A short (one-line) description of the package. +synopsis: An IRC client library. + +-- A longer description of the package. +description: + An IRC client library built atop + <http://hackage.haskell.org/package/irc-conduit irc-conduit>. Why + another IRC client library, you cry? I didn't really find one that + did what I wanted (specifically, handle connecting to servers and + calling event handlers, possibly with TLS), but which didn't + implement almost a full IRC bot for you. That takes out all the fun! + . + <http://hackage.haskell.org/package/irc-conduit irc-conduit> and + <http://hackage.haskell.org/package/irc-ctcp irc-ctcp> are my + solution to the first part of that, this is my solution to the + latter. It's a simple IRC client library that does the basics for + you, but isn't an all-singing, all-dancing, fully-featured IRC + /application/. It is a merely a simple library. + +-- URL for the project homepage or repository. +homepage: https://github.com/barrucadu/irc-client + +-- URL where users should direct bug reports. +bug-reports: https://github.com/barrucadu/irc-client/issues + +-- The license under which the package is released. +license: MIT + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Michael Walker + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: mike@barrucadu.co.uk + +-- A copyright notice. +-- copyright: + +category: Network + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a +-- README. +-- extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.10 + + +library + -- Modules exported by the library. + exposed-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.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 + , mtl >=2.1 && <2.3 + , network-conduit-tls >=1.1 && <1.4 + , old-locale >=1.0 && <1.1 + , profunctors >=5 && <6 + , stm >=2.4 && <2.6 + , stm-chans >=2.0 && <3.1 + , text >=1.1 && <1.3 + , 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 + , x509-validation >=1.6 && <1.7 + + -- Directories containing source files. + -- hs-source-dirs: + + -- Base language which the package is written in. + default-language: Haskell2010 + + ghc-options: -Wall + +source-repository head + type: git + location: https://github.com/barrucadu/irc-client.git + +source-repository this + type: git + location: https://github.com/barrucadu/irc-client.git + tag: 1.1.2.3 |