From 5976161a7649cca7cd56d4335316179031a364ab Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Sun, 15 Oct 2023 21:41:13 +0200
Subject: Vendor in irc-client
Also:
- Make irc-client decode incoming UTF8 leniently
- Remove some redundant imports
- Switch to GHC 9.4.7
---
vendor/irc-client/LICENSE | 20 ++
vendor/irc-client/Network/IRC/Client.hs | 296 +++++++++++++++++
vendor/irc-client/Network/IRC/Client/Events.hs | 328 +++++++++++++++++++
vendor/irc-client/Network/IRC/Client/Internal.hs | 358 +++++++++++++++++++++
.../irc-client/Network/IRC/Client/Internal/Lens.hs | 88 +++++
.../Network/IRC/Client/Internal/Types.hs | 168 ++++++++++
vendor/irc-client/Network/IRC/Client/Lens.hs | 189 +++++++++++
vendor/irc-client/Network/IRC/Client/Utils.hs | 156 +++++++++
vendor/irc-client/Setup.hs | 2 +
vendor/irc-client/irc-client.cabal | 127 ++++++++
10 files changed, 1732 insertions(+)
create mode 100644 vendor/irc-client/LICENSE
create mode 100644 vendor/irc-client/Network/IRC/Client.hs
create mode 100644 vendor/irc-client/Network/IRC/Client/Events.hs
create mode 100644 vendor/irc-client/Network/IRC/Client/Internal.hs
create mode 100644 vendor/irc-client/Network/IRC/Client/Internal/Lens.hs
create mode 100644 vendor/irc-client/Network/IRC/Client/Internal/Types.hs
create mode 100644 vendor/irc-client/Network/IRC/Client/Lens.hs
create mode 100644 vendor/irc-client/Network/IRC/Client/Utils.hs
create mode 100644 vendor/irc-client/Setup.hs
create mode 100644 vendor/irc-client/irc-client.cabal
(limited to 'vendor/irc-client')
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
--
cgit v1.2.3-70-g09d2