diff options
Diffstat (limited to 'vendor/irc-client/Network/IRC/Client')
| -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 |
6 files changed, 1287 insertions, 0 deletions
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 |