{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

-- |
-- Module      : Network.IRC.Client.Events
-- Copyright   : (c) 2017 Michael Walker
-- License     : MIT
-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>
-- Stability   : experimental
-- Portability : CPP, OverloadedStrings, RankNTypes
--
-- Events and event handlers. When a message is received from the
-- server, all matching handlers are executed sequentially in the
-- order that they appear in the 'handlers' list.
module Network.IRC.Client.Events
  ( -- * Handlers
    EventHandler(..)
  , matchCTCP
  , matchNumeric
  , matchType
  , matchWhen

  -- * Default handlers
  , defaultEventHandlers
  , defaultOnConnect
  , defaultOnDisconnect

  -- ** Individual handlers
  , pingHandler
  , kickHandler
  , ctcpPingHandler
  , ctcpVersionHandler
  , ctcpTimeHandler
  , welcomeNick
  , joinOnWelcome
  , joinHandler
  , nickMangler

  -- * Re-exported
  , Event(..)
  , Message(..)
  , Source(..)
  , module Network.IRC.Conduit.Lens
  ) where

import           Control.Applicative         ((<$>), (<|>))
import           Control.Concurrent.STM      (atomically, modifyTVar, readTVar)
import           Control.Monad.Catch         (SomeException, fromException,
                                              throwM)
import           Control.Monad.IO.Class      (liftIO)
import           Data.Char                   (isAlphaNum)
import           Data.Maybe                  (fromMaybe)
import           Data.Monoid                 ((<>))
import           Data.Text                   (Text, breakOn, takeEnd, toUpper)
import           Data.Time.Clock             (getCurrentTime)
import           Data.Time.Format            (formatTime)
import           Network.IRC.CTCP            (fromCTCP)
import           Network.IRC.Conduit         (Event(..), Message(..),
                                              Source(..))
import           Network.IRC.Conduit.Lens

#if MIN_VERSION_time(1,5,0)
import           Data.Time.Format            (defaultTimeLocale)
#else
import           System.Locale               (defaultTimeLocale)
#endif

import qualified Data.Text                   as T

import           Network.IRC.Client.Internal
import           Network.IRC.Client.Lens
import           Network.IRC.Client.Utils


-------------------------------------------------------------------------------
-- Handlers

-- | Match the verb of a CTCP, ignoring case, and returning the arguments.
--
-- > matchCTCP "ping"   ":foo PRIVMSG #bar :\001PING\001"          ==> Just []
-- > matchCTCP "PING"   ":foo PRIVMSG #bar :\001PING\001"          ==> Just []
-- > matchCTCP "ACTION" ":foo PRIVMSG #bar :\001ACTION dances\001" ==> Just ["dances"]
matchCTCP :: Text -> Event Text -> Maybe [Text]
matchCTCP :: Text -> Event Text -> Maybe [Text]
matchCTCP Text
verb Event Text
ev = case Event Text -> Message Text
forall a. Event a -> Message a
_message Event Text
ev of
  Privmsg Text
_ (Left CTCPByteString
ctcpbs) ->
    let (Text
v, [Text]
args) = CTCPByteString -> (Text, [Text])
fromCTCP CTCPByteString
ctcpbs
    in if Text -> Text
toUpper Text
verb Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Text
toUpper Text
v
       then [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text]
args
       else Maybe [Text]
forall a. Maybe a
Nothing
  Message Text
_ -> Maybe [Text]
forall a. Maybe a
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 :: Int -> Event a -> Maybe [a]
matchNumeric Int
num Event a
ev = case Event a -> Message a
forall a. Event a -> Message a
_message Event a
ev of
  Numeric Int
n [a]
args | Int
num Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n -> [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a]
args
  Message a
_ -> Maybe [a]
forall a. Maybe a
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 :: Prism' (Message a) b -> Event a -> Maybe b
matchType Prism' (Message a) b
k = Prism' (Message a) b -> Message a -> Maybe b
forall s a. Prism' s a -> s -> Maybe a
preview Prism' (Message a) b
k (Message a -> Maybe b)
-> (Event a -> Message a) -> Event a -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event a -> Message a
forall a. Event a -> Message a
_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 :: (Event a -> Bool) -> Event a -> Maybe (Message a)
matchWhen Event a -> Bool
p Event a
ev | Event a -> Bool
p Event a
ev = Message a -> Maybe (Message a)
forall a. a -> Maybe a
Just (Event a -> Message a
forall a. Event a -> Message a
_message Event a
ev)
matchWhen Event a -> Bool
_ Event a
_ = Maybe (Message a)
forall a. Maybe a
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 :: [EventHandler s]
defaultEventHandlers =
  [ EventHandler s
forall s. EventHandler s
pingHandler
  , EventHandler s
forall s. EventHandler s
kickHandler
  , EventHandler s
forall s. EventHandler s
ctcpPingHandler
  , EventHandler s
forall s. EventHandler s
ctcpTimeHandler
  , EventHandler s
forall s. EventHandler s
ctcpVersionHandler
  , EventHandler s
forall s. EventHandler s
welcomeNick
  , EventHandler s
forall s. EventHandler s
joinOnWelcome
  , EventHandler s
forall s. EventHandler s
joinHandler
  , EventHandler s
forall s. EventHandler s
nickMangler
  ]

-- | The default connect handler: set the nick.
defaultOnConnect :: IRC s ()
defaultOnConnect :: IRC s ()
defaultOnConnect = do
  InstanceConfig s
iconf <- Getting
  (TVar (InstanceConfig s)) (IRCState s) (TVar (InstanceConfig s))
-> IRCState s -> IRC s (InstanceConfig s)
forall (m :: * -> *) a s.
MonadIO m =>
Getting (TVar a) s (TVar a) -> s -> m a
snapshot Getting
  (TVar (InstanceConfig s)) (IRCState s) (TVar (InstanceConfig s))
forall s. Lens' (IRCState s) (TVar (InstanceConfig s))
instanceConfig (IRCState s -> IRC s (InstanceConfig s))
-> IRC s (IRCState s) -> IRC s (InstanceConfig s)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IRC s (IRCState s)
forall s. IRC s (IRCState s)
getIRCState
  Message Text -> IRC s ()
forall s. Message Text -> IRC s ()
send (Message Text -> IRC s ())
-> (Text -> Message Text) -> Text -> IRC s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Message Text
forall a. NickName a -> Message (NickName a)
Nick (Text -> IRC s ()) -> Text -> IRC s ()
forall a b. (a -> b) -> a -> b
$ Getting Text (InstanceConfig s) Text -> InstanceConfig s -> Text
forall a s. Getting a s a -> s -> a
get Getting Text (InstanceConfig s) Text
forall s. Lens' (InstanceConfig s) Text
nick InstanceConfig s
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 :: Maybe SomeException -> IRC s ()
defaultOnDisconnect (Just SomeException
exc) = case SomeException -> Maybe Timeout
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc of
  Just Timeout
Timeout -> IRC s ()
forall s. IRC s ()
reconnect
  Maybe Timeout
Nothing -> SomeException -> IRC s ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
exc
defaultOnDisconnect Maybe SomeException
Nothing = () -> IRC s ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-------------------------------------------------------------------------------
-- Individual handlers

-- | Respond to server @PING@ messages with a @PONG@.
pingHandler :: EventHandler s
pingHandler :: EventHandler s
pingHandler = (Event Text -> Maybe (Text, Maybe Text))
-> (Source Text -> (Text, Maybe Text) -> IRC s ())
-> EventHandler s
forall b s.
(Event Text -> Maybe b)
-> (Source Text -> b -> IRC s ()) -> EventHandler s
EventHandler (Prism' (Message Text) (Text, Maybe Text)
-> Event Text -> Maybe (Text, Maybe Text)
forall a b. Prism' (Message a) b -> Event a -> Maybe b
matchType forall a. Prism' (Message a) (a, Maybe a)
Prism' (Message Text) (Text, Maybe Text)
_Ping) ((Source Text -> (Text, Maybe Text) -> IRC s ()) -> EventHandler s)
-> (Source Text -> (Text, Maybe Text) -> IRC s ())
-> EventHandler s
forall a b. (a -> b) -> a -> b
$ \Source Text
_ (Text
s1, Maybe Text
s2) ->
  Message Text -> IRC s ()
forall s. Message Text -> IRC s ()
send (Message Text -> IRC s ())
-> (Text -> Message Text) -> Text -> IRC s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Message Text
forall a. NickName a -> Message (NickName a)
Pong (Text -> IRC s ()) -> Text -> IRC s ()
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
s1 Maybe Text
s2

-- | Respond to CTCP @PING@ requests.
ctcpPingHandler :: EventHandler s
ctcpPingHandler :: EventHandler s
ctcpPingHandler = (Event Text -> Maybe [Text])
-> (Source Text -> [Text] -> IRC s ()) -> EventHandler s
forall b s.
(Event Text -> Maybe b)
-> (Source Text -> b -> IRC s ()) -> EventHandler s
EventHandler (Text -> Event Text -> Maybe [Text]
matchCTCP Text
"PING") ((Source Text -> [Text] -> IRC s ()) -> EventHandler s)
-> (Source Text -> [Text] -> IRC s ()) -> EventHandler s
forall a b. (a -> b) -> a -> b
$ \Source Text
src [Text]
args -> case Source Text
src of
  User Text
n -> Message Text -> IRC s ()
forall s. Message Text -> IRC s ()
send (Message Text -> IRC s ()) -> Message Text -> IRC s ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text] -> Message Text
ctcpReply Text
n Text
"PING" [Text]
args
  Source Text
_ -> () -> IRC s ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Respond to CTCP @VERSION@ requests with the version string.
ctcpVersionHandler :: EventHandler s
ctcpVersionHandler :: EventHandler s
ctcpVersionHandler = (Event Text -> Maybe [Text])
-> (Source Text -> [Text] -> IRC s ()) -> EventHandler s
forall b s.
(Event Text -> Maybe b)
-> (Source Text -> b -> IRC s ()) -> EventHandler s
EventHandler (Text -> Event Text -> Maybe [Text]
matchCTCP Text
"VERSION") ((Source Text -> [Text] -> IRC s ()) -> EventHandler s)
-> (Source Text -> [Text] -> IRC s ()) -> EventHandler s
forall a b. (a -> b) -> a -> b
$ \Source Text
src [Text]
_ -> case Source Text
src of
  User Text
n -> do
    Text
ver <- Getting Text (InstanceConfig s) Text -> InstanceConfig s -> Text
forall a s. Getting a s a -> s -> a
get Getting Text (InstanceConfig s) Text
forall s. Lens' (InstanceConfig s) Text
version (InstanceConfig s -> Text)
-> IRC s (InstanceConfig s) -> IRC s Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Getting
  (TVar (InstanceConfig s)) (IRCState s) (TVar (InstanceConfig s))
-> IRCState s -> IRC s (InstanceConfig s)
forall (m :: * -> *) a s.
MonadIO m =>
Getting (TVar a) s (TVar a) -> s -> m a
snapshot Getting
  (TVar (InstanceConfig s)) (IRCState s) (TVar (InstanceConfig s))
forall s. Lens' (IRCState s) (TVar (InstanceConfig s))
instanceConfig (IRCState s -> IRC s (InstanceConfig s))
-> IRC s (IRCState s) -> IRC s (InstanceConfig s)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IRC s (IRCState s)
forall s. IRC s (IRCState s)
getIRCState)
    Message Text -> IRC s ()
forall s. Message Text -> IRC s ()
send (Message Text -> IRC s ()) -> Message Text -> IRC s ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text] -> Message Text
ctcpReply Text
n Text
"VERSION" [Text
ver]
  Source Text
_ -> () -> IRC s ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Respond to CTCP @TIME@ requests with the system time.
ctcpTimeHandler :: EventHandler s
ctcpTimeHandler :: EventHandler s
ctcpTimeHandler = (Event Text -> Maybe [Text])
-> (Source Text -> [Text] -> IRC s ()) -> EventHandler s
forall b s.
(Event Text -> Maybe b)
-> (Source Text -> b -> IRC s ()) -> EventHandler s
EventHandler (Text -> Event Text -> Maybe [Text]
matchCTCP Text
"TIME") ((Source Text -> [Text] -> IRC s ()) -> EventHandler s)
-> (Source Text -> [Text] -> IRC s ()) -> EventHandler s
forall a b. (a -> b) -> a -> b
$ \Source Text
src [Text]
_ -> case Source Text
src of
  User Text
n -> do
    UTCTime
now <- IO UTCTime -> IRC s UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    Message Text -> IRC s ()
forall s. Message Text -> IRC s ()
send (Message Text -> IRC s ()) -> Message Text -> IRC s ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text] -> Message Text
ctcpReply Text
n Text
"TIME" [String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%c" UTCTime
now]
  Source Text
_ -> () -> IRC s ()
forall (f :: * -> *) a. Applicative f => a -> f a
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 s
welcomeNick = (Event Text -> Maybe [Text])
-> (Source Text -> [Text] -> IRC s ()) -> EventHandler s
forall b s.
(Event Text -> Maybe b)
-> (Source Text -> b -> IRC s ()) -> EventHandler s
EventHandler (Int -> Event Text -> Maybe [Text]
forall a. Int -> Event a -> Maybe [a]
matchNumeric Int
001) ((Source Text -> [Text] -> IRC s ()) -> EventHandler s)
-> (Source Text -> [Text] -> IRC s ()) -> EventHandler s
forall a b. (a -> b) -> a -> b
$ \Source Text
_ [Text]
args -> case [Text]
args of
  (Text
srvNick:[Text]
_) -> do
    TVar (InstanceConfig s)
tvarI <- Getting
  (TVar (InstanceConfig s)) (IRCState s) (TVar (InstanceConfig s))
-> IRCState s -> TVar (InstanceConfig s)
forall a s. Getting a s a -> s -> a
get Getting
  (TVar (InstanceConfig s)) (IRCState s) (TVar (InstanceConfig s))
forall s. Lens' (IRCState s) (TVar (InstanceConfig s))
instanceConfig (IRCState s -> TVar (InstanceConfig s))
-> IRC s (IRCState s) -> IRC s (TVar (InstanceConfig s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IRC s (IRCState s)
forall s. IRC s (IRCState s)
getIRCState
    IO () -> IRC s ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IRC s ()) -> (STM () -> IO ()) -> STM () -> IRC s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IRC s ()) -> STM () -> IRC s ()
forall a b. (a -> b) -> a -> b
$
      TVar (InstanceConfig s)
-> (InstanceConfig s -> InstanceConfig s) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (InstanceConfig s)
tvarI (Lens' (InstanceConfig s) Text
-> Text -> InstanceConfig s -> InstanceConfig s
forall s a. Lens' s a -> a -> s -> s
set forall s. Lens' (InstanceConfig s) Text
Lens' (InstanceConfig s) Text
nick Text
srvNick)
  [] -> () -> IRC s ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Join default channels upon welcome (numeric reply 001). If sent earlier,
-- the server might reject the JOIN attempts.
joinOnWelcome :: EventHandler s
joinOnWelcome :: EventHandler s
joinOnWelcome = (Event Text -> Maybe [Text])
-> (Source Text -> [Text] -> IRC s ()) -> EventHandler s
forall b s.
(Event Text -> Maybe b)
-> (Source Text -> b -> IRC s ()) -> EventHandler s
EventHandler (Int -> Event Text -> Maybe [Text]
forall a. Int -> Event a -> Maybe [a]
matchNumeric Int
001) ((Source Text -> [Text] -> IRC s ()) -> EventHandler s)
-> (Source Text -> [Text] -> IRC s ()) -> EventHandler s
forall a b. (a -> b) -> a -> b
$ \Source Text
_ [Text]
_ -> do
  InstanceConfig s
iconf <- Getting
  (TVar (InstanceConfig s)) (IRCState s) (TVar (InstanceConfig s))
-> IRCState s -> IRC s (InstanceConfig s)
forall (m :: * -> *) a s.
MonadIO m =>
Getting (TVar a) s (TVar a) -> s -> m a
snapshot Getting
  (TVar (InstanceConfig s)) (IRCState s) (TVar (InstanceConfig s))
forall s. Lens' (IRCState s) (TVar (InstanceConfig s))
instanceConfig (IRCState s -> IRC s (InstanceConfig s))
-> IRC s (IRCState s) -> IRC s (InstanceConfig s)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IRC s (IRCState s)
forall s. IRC s (IRCState s)
getIRCState
  (Text -> IRC s ()) -> [Text] -> IRC s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Message Text -> IRC s ()
forall s. Message Text -> IRC s ()
send (Message Text -> IRC s ())
-> (Text -> Message Text) -> Text -> IRC s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Message Text
forall a. NickName a -> Message (NickName a)
Join) ([Text] -> IRC s ()) -> [Text] -> IRC s ()
forall a b. (a -> b) -> a -> b
$ Getting [Text] (InstanceConfig s) [Text]
-> InstanceConfig s -> [Text]
forall a s. Getting a s a -> s -> a
get Getting [Text] (InstanceConfig s) [Text]
forall s. Lens' (InstanceConfig s) [Text]
channels InstanceConfig s
iconf

-- | Mangle the nick if there's a collision (numeric replies 432, 433,
-- and 436) when we set it
nickMangler :: EventHandler s
nickMangler :: EventHandler s
nickMangler = (Event Text -> Maybe (Text -> Text, [Text]))
-> (Source Text -> (Text -> Text, [Text]) -> IRC s ())
-> EventHandler s
forall b s.
(Event Text -> Maybe b)
-> (Source Text -> b -> IRC s ()) -> EventHandler s
EventHandler (\Event Text
ev -> Int -> (Text -> Text) -> Event Text -> Maybe (Text -> Text, [Text])
forall a a. Int -> a -> Event a -> Maybe (a, [a])
matcher Int
432 Text -> Text
fresh Event Text
ev Maybe (Text -> Text, [Text])
-> Maybe (Text -> Text, [Text]) -> Maybe (Text -> Text, [Text])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> (Text -> Text) -> Event Text -> Maybe (Text -> Text, [Text])
forall a a. Int -> a -> Event a -> Maybe (a, [a])
matcher Int
433 Text -> Text
mangle Event Text
ev Maybe (Text -> Text, [Text])
-> Maybe (Text -> Text, [Text]) -> Maybe (Text -> Text, [Text])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> (Text -> Text) -> Event Text -> Maybe (Text -> Text, [Text])
forall a a. Int -> a -> Event a -> Maybe (a, [a])
matcher Int
436 Text -> Text
mangle Event Text
ev) ((Source Text -> (Text -> Text, [Text]) -> IRC s ())
 -> EventHandler s)
-> (Source Text -> (Text -> Text, [Text]) -> IRC s ())
-> EventHandler s
forall a b. (a -> b) -> a -> b
$ \Source Text
_ -> ((Text -> Text) -> [Text] -> IRC s ())
-> (Text -> Text, [Text]) -> IRC s ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Text -> Text) -> [Text] -> IRC s ()
forall s. (Text -> Text) -> [Text] -> IRC s ()
go
  where
    matcher :: Int -> a -> Event a -> Maybe (a, [a])
matcher Int
num a
f Event a
ev = case Event a -> Message a
forall a. Event a -> Message a
_message Event a
ev of
      Numeric Int
n [a]
args | Int
num Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n -> (a, [a]) -> Maybe (a, [a])
forall a. a -> Maybe a
Just (a
f, [a]
args)
      Message a
_ -> Maybe (a, [a])
forall a. Maybe a
Nothing

    go :: (Text -> Text) -> [Text] -> IRC s ()
go Text -> Text
f (Text
_:Text
srvNick:[Text]
_) = do
      Text
theNick <- Getting Text (InstanceConfig s) Text -> InstanceConfig s -> Text
forall a s. Getting a s a -> s -> a
get Getting Text (InstanceConfig s) Text
forall s. Lens' (InstanceConfig s) Text
nick (InstanceConfig s -> Text)
-> IRC s (InstanceConfig s) -> IRC s Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Getting
  (TVar (InstanceConfig s)) (IRCState s) (TVar (InstanceConfig s))
-> IRCState s -> IRC s (InstanceConfig s)
forall (m :: * -> *) a s.
MonadIO m =>
Getting (TVar a) s (TVar a) -> s -> m a
snapshot Getting
  (TVar (InstanceConfig s)) (IRCState s) (TVar (InstanceConfig s))
forall s. Lens' (IRCState s) (TVar (InstanceConfig s))
instanceConfig (IRCState s -> IRC s (InstanceConfig s))
-> IRC s (IRCState s) -> IRC s (InstanceConfig s)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IRC s (IRCState s)
forall s. IRC s (IRCState s)
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 :: Maybe Int
nicklen = if Text -> Int
T.length Text
srvNick Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Int
T.length Text
theNick
                    then Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Text -> Int
T.length Text
srvNick
                    else Maybe Int
forall a. Maybe a
Nothing

      Text -> IRC s ()
forall s. Text -> IRC s ()
setNick (Text -> IRC s ()) -> (Text -> Text) -> Text -> IRC s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> Text -> Text
trunc Maybe Int
nicklen (Text -> IRC s ()) -> Text -> IRC s ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
f Text
srvNick
    go Text -> Text
_ [Text]
_ = () -> IRC s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    fresh :: Text -> Text
fresh Text
n = if Text -> Int
T.length Text
n' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Text
"f" else Text
n'
      where n' :: Text
n' = (Char -> Bool) -> Text -> Text
T.filter Char -> Bool
isAlphaNum Text
n

    mangle :: Text -> Text
mangle Text
n = (Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"1") Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
`fromMaybe` Text -> Maybe Text
charsubst Text
n

    -- Truncate a nick, if there is a known length limit.
    trunc :: Maybe Int -> Text -> Text
trunc Maybe Int
len Text
txt = Text -> (Int -> Text) -> Maybe Int -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
txt (Int -> Text -> Text
`takeEnd` Text
txt) Maybe Int
len

    -- List of substring substitutions. It's important that these
    -- don't contain any loops!
    charsubst :: Text -> Maybe Text
charsubst = [(Text, Text)] -> Text -> Maybe Text
transform [ (Text
"i", Text
"1")
                          , (Text
"I", Text
"1")
                          , (Text
"l", Text
"1")
                          , (Text
"L", Text
"1")
                          , (Text
"o", Text
"0")
                          , (Text
"O", Text
"0")
                          , (Text
"A", Text
"4")
                          , (Text
"0", Text
"1")
                          , (Text
"1", Text
"2")
                          , (Text
"2", Text
"3")
                          , (Text
"3", Text
"4")
                          , (Text
"4", Text
"5")
                          , (Text
"5", Text
"6")
                          , (Text
"6", Text
"7")
                          , (Text
"7", Text
"8")
                          , (Text
"8", Text
"9")
                          , (Text
"9", Text
"-")
                          ]

    -- Attempt to transform some text by the substitutions.
    transform :: [(Text, Text)] -> Text -> Maybe Text
transform ((Text
from, Text
to):[(Text, Text)]
trs) Text
txt = case Text -> Text -> Maybe (Text, Text)
breakOn' Text
from Text
txt of
      Just (Text
before, Text
after) -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
before Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
to Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
after
      Maybe (Text, Text)
_ -> [(Text, Text)] -> Text -> Maybe Text
transform [(Text, Text)]
trs Text
txt
    transform [] Text
_ = Maybe Text
forall a. Maybe a
Nothing

-- | Upon joining a channel (numeric reply 331 or 332), add it to the
-- list (if not already present).
joinHandler :: EventHandler s
joinHandler :: EventHandler s
joinHandler = (Event Text -> Maybe [Text])
-> (Source Text -> [Text] -> IRC s ()) -> EventHandler s
forall b s.
(Event Text -> Maybe b)
-> (Source Text -> b -> IRC s ()) -> EventHandler s
EventHandler (\Event Text
ev -> Int -> Event Text -> Maybe [Text]
forall a. Int -> Event a -> Maybe [a]
matchNumeric Int
331 Event Text
ev Maybe [Text] -> Maybe [Text] -> Maybe [Text]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Event Text -> Maybe [Text]
forall a. Int -> Event a -> Maybe [a]
matchNumeric Int
332 Event Text
ev) ((Source Text -> [Text] -> IRC s ()) -> EventHandler s)
-> (Source Text -> [Text] -> IRC s ()) -> EventHandler s
forall a b. (a -> b) -> a -> b
$ \Source Text
_ [Text]
args -> case [Text]
args of
  (Text
c:[Text]
_) -> do
    TVar (InstanceConfig s)
tvarI <- Getting
  (TVar (InstanceConfig s)) (IRCState s) (TVar (InstanceConfig s))
-> IRCState s -> TVar (InstanceConfig s)
forall a s. Getting a s a -> s -> a
get Getting
  (TVar (InstanceConfig s)) (IRCState s) (TVar (InstanceConfig s))
forall s. Lens' (IRCState s) (TVar (InstanceConfig s))
instanceConfig (IRCState s -> TVar (InstanceConfig s))
-> IRC s (IRCState s) -> IRC s (TVar (InstanceConfig s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IRC s (IRCState s)
forall s. IRC s (IRCState s)
getIRCState
    IO () -> IRC s ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IRC s ()) -> (STM () -> IO ()) -> STM () -> IRC s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IRC s ()) -> STM () -> IRC s ()
forall a b. (a -> b) -> a -> b
$
      TVar (InstanceConfig s)
-> (InstanceConfig s -> InstanceConfig s) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (InstanceConfig s)
tvarI ((InstanceConfig s -> InstanceConfig s) -> STM ())
-> (InstanceConfig s -> InstanceConfig s) -> STM ()
forall a b. (a -> b) -> a -> b
$ \InstanceConfig s
iconf ->
        (if Text
c Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Getting [Text] (InstanceConfig s) [Text]
-> InstanceConfig s -> [Text]
forall a s. Getting a s a -> s -> a
get Getting [Text] (InstanceConfig s) [Text]
forall s. Lens' (InstanceConfig s) [Text]
channels InstanceConfig s
iconf
          then Lens' (InstanceConfig s) [Text]
-> ([Text] -> [Text]) -> InstanceConfig s -> InstanceConfig s
forall s a. Lens' s a -> (a -> a) -> s -> s
modify forall s. Lens' (InstanceConfig s) [Text]
Lens' (InstanceConfig s) [Text]
channels (Text
cText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:)
          else InstanceConfig s -> InstanceConfig s
forall a. a -> a
id) InstanceConfig s
iconf
  [Text]
_ -> () -> IRC s ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Update the channel list upon being kicked.
kickHandler :: EventHandler s
kickHandler :: EventHandler s
kickHandler = (Event Text -> Maybe (Text, Text, Maybe Text))
-> (Source Text -> (Text, Text, Maybe Text) -> IRC s ())
-> EventHandler s
forall b s.
(Event Text -> Maybe b)
-> (Source Text -> b -> IRC s ()) -> EventHandler s
EventHandler (Prism' (Message Text) (Text, Text, Maybe Text)
-> Event Text -> Maybe (Text, Text, Maybe Text)
forall a b. Prism' (Message a) b -> Event a -> Maybe b
matchType forall a. Prism' (Message a) (a, a, Reason a)
Prism' (Message Text) (Text, Text, Maybe Text)
_Kick) ((Source Text -> (Text, Text, Maybe Text) -> IRC s ())
 -> EventHandler s)
-> (Source Text -> (Text, Text, Maybe Text) -> IRC s ())
-> EventHandler s
forall a b. (a -> b) -> a -> b
$ \Source Text
src (Text
n, Text
_, Maybe Text
_) -> do
  TVar (InstanceConfig s)
tvarI <- Getting
  (TVar (InstanceConfig s)) (IRCState s) (TVar (InstanceConfig s))
-> IRCState s -> TVar (InstanceConfig s)
forall a s. Getting a s a -> s -> a
get Getting
  (TVar (InstanceConfig s)) (IRCState s) (TVar (InstanceConfig s))
forall s. Lens' (IRCState s) (TVar (InstanceConfig s))
instanceConfig (IRCState s -> TVar (InstanceConfig s))
-> IRC s (IRCState s) -> IRC s (TVar (InstanceConfig s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IRC s (IRCState s)
forall s. IRC s (IRCState s)
getIRCState
  IO () -> IRC s ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IRC s ()) -> (STM () -> IO ()) -> STM () -> IRC s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IRC s ()) -> STM () -> IRC s ()
forall a b. (a -> b) -> a -> b
$ do
    Text
theNick <- Getting Text (InstanceConfig s) Text -> InstanceConfig s -> Text
forall a s. Getting a s a -> s -> a
get Getting Text (InstanceConfig s) Text
forall s. Lens' (InstanceConfig s) Text
nick (InstanceConfig s -> Text) -> STM (InstanceConfig s) -> STM Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (InstanceConfig s) -> STM (InstanceConfig s)
forall a. TVar a -> STM a
readTVar TVar (InstanceConfig s)
tvarI
    case Source Text
src of
      Channel Text
c Text
_
        | Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
theNick -> TVar (InstanceConfig s) -> Text -> STM ()
forall s. TVar (InstanceConfig s) -> Text -> STM ()
delChan TVar (InstanceConfig s)
tvarI Text
c
        | Bool
otherwise    -> () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Source Text
_ -> () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
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' :: Text -> Text -> Maybe (Text, Text)
breakOn' Text
delim Text
txt = if Text -> Int
T.length Text
after Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Text -> Int
T.length Text
delim
                     then (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
before, Int -> Text -> Text
T.drop (Text -> Int
T.length Text
delim) Text
after)
                     else Maybe (Text, Text)
forall a. Maybe a
Nothing
  where
    (Text
before, Text
after) = Text -> Text -> (Text, Text)
breakOn Text
delim Text
txt