{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Network.IRC.Client.Events
(
EventHandler(..)
, matchCTCP
, matchNumeric
, matchType
, matchWhen
, defaultEventHandlers
, defaultOnConnect
, defaultOnDisconnect
, pingHandler
, kickHandler
, ctcpPingHandler
, ctcpVersionHandler
, ctcpTimeHandler
, welcomeNick
, joinOnWelcome
, joinHandler
, nickMangler
, 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.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
matchCTCP :: Text -> Event Text -> Maybe [Text]
matchCTCP :: Text -> Event Text -> Maybe [Text]
matchCTCP Text
verb Event Text
ev = case 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 forall a. Eq a => a -> a -> Bool
== Text -> Text
toUpper Text
v
then forall a. a -> Maybe a
Just [Text]
args
else forall a. Maybe a
Nothing
Message Text
_ -> forall a. Maybe a
Nothing
matchNumeric :: Int -> Event a -> Maybe [a]
matchNumeric :: forall a. Int -> Event a -> Maybe [a]
matchNumeric Int
num Event a
ev = case forall a. Event a -> Message a
_message Event a
ev of
Numeric Int
n [a]
args | Int
num forall a. Eq a => a -> a -> Bool
== Int
n -> forall a. a -> Maybe a
Just [a]
args
Message a
_ -> forall a. Maybe a
Nothing
matchType :: Prism' (Message a) b -> Event a -> Maybe b
matchType :: forall a b. Prism' (Message a) b -> Event a -> Maybe b
matchType Prism' (Message a) b
k = forall s a. Prism' s a -> s -> Maybe a
preview Prism' (Message a) b
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Event a -> Message a
_message
matchWhen :: (Event a -> Bool) -> Event a -> Maybe (Message a)
matchWhen :: forall a. (Event a -> Bool) -> Event a -> Maybe (Message a)
matchWhen Event a -> Bool
p Event a
ev | Event a -> Bool
p Event a
ev = forall a. a -> Maybe a
Just (forall a. Event a -> Message a
_message Event a
ev)
matchWhen Event a -> Bool
_ Event a
_ = forall a. Maybe a
Nothing
defaultEventHandlers :: [EventHandler s]
defaultEventHandlers :: forall s. [EventHandler s]
defaultEventHandlers =
[ forall s. EventHandler s
pingHandler
, forall s. EventHandler s
kickHandler
, forall s. EventHandler s
ctcpPingHandler
, forall s. EventHandler s
ctcpTimeHandler
, forall s. EventHandler s
ctcpVersionHandler
, forall s. EventHandler s
welcomeNick
, forall s. EventHandler s
joinOnWelcome
, forall s. EventHandler s
joinHandler
, forall s. EventHandler s
nickMangler
]
defaultOnConnect :: IRC s ()
defaultOnConnect :: forall s. IRC s ()
defaultOnConnect = do
InstanceConfig s
iconf <- forall (m :: * -> *) a s.
MonadIO m =>
Getting (TVar a) s (TVar a) -> s -> m a
snapshot forall s. Lens' (IRCState s) (TVar (InstanceConfig s))
instanceConfig forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s. IRC s (IRCState s)
getIRCState
forall s. Message Text -> IRC s ()
send forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NickName a -> Message (NickName a)
Nick forall a b. (a -> b) -> a -> b
$ forall a s. Getting a s a -> s -> a
get forall s. Lens' (InstanceConfig s) Text
nick InstanceConfig s
iconf
defaultOnDisconnect :: Maybe SomeException -> IRC s ()
defaultOnDisconnect :: forall s. Maybe SomeException -> IRC s ()
defaultOnDisconnect (Just SomeException
exc) = case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc of
Just Timeout
Timeout -> forall s. IRC s ()
reconnect
Maybe Timeout
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
exc
defaultOnDisconnect Maybe SomeException
Nothing = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
pingHandler :: EventHandler s
pingHandler :: forall s. EventHandler s
pingHandler = forall b s.
(Event Text -> Maybe b)
-> (Source Text -> b -> IRC s ()) -> EventHandler s
EventHandler (forall a b. Prism' (Message a) b -> Event a -> Maybe b
matchType forall a. Prism' (Message a) (a, Maybe a)
_Ping) forall a b. (a -> b) -> a -> b
$ \Source Text
_ (Text
s1, Maybe Text
s2) ->
forall s. Message Text -> IRC s ()
send forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NickName a -> Message (NickName a)
Pong forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Text
s1 Maybe Text
s2
ctcpPingHandler :: EventHandler s
ctcpPingHandler :: forall s. EventHandler s
ctcpPingHandler = forall b s.
(Event Text -> Maybe b)
-> (Source Text -> b -> IRC s ()) -> EventHandler s
EventHandler (Text -> Event Text -> Maybe [Text]
matchCTCP Text
"PING") forall a b. (a -> b) -> a -> b
$ \Source Text
src [Text]
args -> case Source Text
src of
User Text
n -> forall s. Message Text -> IRC s ()
send forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text] -> Message Text
ctcpReply Text
n Text
"PING" [Text]
args
Source Text
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ctcpVersionHandler :: EventHandler s
ctcpVersionHandler :: forall s. EventHandler s
ctcpVersionHandler = forall b s.
(Event Text -> Maybe b)
-> (Source Text -> b -> IRC s ()) -> EventHandler s
EventHandler (Text -> Event Text -> Maybe [Text]
matchCTCP Text
"VERSION") forall a b. (a -> b) -> a -> b
$ \Source Text
src [Text]
_ -> case Source Text
src of
User Text
n -> do
Text
ver <- forall a s. Getting a s a -> s -> a
get forall s. Lens' (InstanceConfig s) Text
version forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) a s.
MonadIO m =>
Getting (TVar a) s (TVar a) -> s -> m a
snapshot forall s. Lens' (IRCState s) (TVar (InstanceConfig s))
instanceConfig forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s. IRC s (IRCState s)
getIRCState)
forall s. Message Text -> IRC s ()
send forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text] -> Message Text
ctcpReply Text
n Text
"VERSION" [Text
ver]
Source Text
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ctcpTimeHandler :: EventHandler s
ctcpTimeHandler :: forall s. EventHandler s
ctcpTimeHandler = forall b s.
(Event Text -> Maybe b)
-> (Source Text -> b -> IRC s ()) -> EventHandler s
EventHandler (Text -> Event Text -> Maybe [Text]
matchCTCP Text
"TIME") forall a b. (a -> b) -> a -> b
$ \Source Text
src [Text]
_ -> case Source Text
src of
User Text
n -> do
UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
forall s. Message Text -> IRC s ()
send forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text] -> Message Text
ctcpReply Text
n Text
"TIME" [String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%c" UTCTime
now]
Source Text
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
welcomeNick :: EventHandler s
welcomeNick :: forall s. EventHandler s
welcomeNick = forall b s.
(Event Text -> Maybe b)
-> (Source Text -> b -> IRC s ()) -> EventHandler s
EventHandler (forall a. Int -> Event a -> Maybe [a]
matchNumeric Int
001) forall a b. (a -> b) -> a -> b
$ \Source Text
_ [Text]
args -> case [Text]
args of
(Text
srvNick:[Text]
_) -> do
TVar (InstanceConfig s)
tvarI <- forall a s. Getting a s a -> s -> a
get forall s. Lens' (IRCState s) (TVar (InstanceConfig s))
instanceConfig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. IRC s (IRCState s)
getIRCState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (InstanceConfig s)
tvarI (forall s a. Lens' s a -> a -> s -> s
set forall s. Lens' (InstanceConfig s) Text
nick Text
srvNick)
[] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
joinOnWelcome :: EventHandler s
joinOnWelcome :: forall s. EventHandler s
joinOnWelcome = forall b s.
(Event Text -> Maybe b)
-> (Source Text -> b -> IRC s ()) -> EventHandler s
EventHandler (forall a. Int -> Event a -> Maybe [a]
matchNumeric Int
001) forall a b. (a -> b) -> a -> b
$ \Source Text
_ [Text]
_ -> do
InstanceConfig s
iconf <- forall (m :: * -> *) a s.
MonadIO m =>
Getting (TVar a) s (TVar a) -> s -> m a
snapshot forall s. Lens' (IRCState s) (TVar (InstanceConfig s))
instanceConfig forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s. IRC s (IRCState s)
getIRCState
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall s. Message Text -> IRC s ()
send forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NickName a -> Message (NickName a)
Join) forall a b. (a -> b) -> a -> b
$ forall a s. Getting a s a -> s -> a
get forall s. Lens' (InstanceConfig s) [Text]
channels InstanceConfig s
iconf
nickMangler :: EventHandler s
nickMangler :: forall s. EventHandler s
nickMangler = forall b s.
(Event Text -> Maybe b)
-> (Source Text -> b -> IRC s ()) -> EventHandler s
EventHandler (\Event Text
ev -> forall {a} {a}. Int -> a -> Event a -> Maybe (a, [a])
matcher Int
432 Text -> Text
fresh Event Text
ev forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {a} {a}. Int -> a -> Event a -> Maybe (a, [a])
matcher Int
433 Text -> Text
mangle Event Text
ev forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {a} {a}. Int -> a -> Event a -> Maybe (a, [a])
matcher Int
436 Text -> Text
mangle Event Text
ev) forall a b. (a -> b) -> a -> b
$ \Source Text
_ -> forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry 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 forall a. Event a -> Message a
_message Event a
ev of
Numeric Int
n [a]
args | Int
num forall a. Eq a => a -> a -> Bool
== Int
n -> forall a. a -> Maybe a
Just (a
f, [a]
args)
Message a
_ -> forall a. Maybe a
Nothing
go :: (Text -> Text) -> [Text] -> IRC s ()
go Text -> Text
f (Text
_:Text
srvNick:[Text]
_) = do
Text
theNick <- forall a s. Getting a s a -> s -> a
get forall s. Lens' (InstanceConfig s) Text
nick forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) a s.
MonadIO m =>
Getting (TVar a) s (TVar a) -> s -> m a
snapshot forall s. Lens' (IRCState s) (TVar (InstanceConfig s))
instanceConfig forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s. IRC s (IRCState s)
getIRCState)
let nicklen :: Maybe Int
nicklen = if Text -> Int
T.length Text
srvNick forall a. Eq a => a -> a -> Bool
/= Text -> Int
T.length Text
theNick
then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Int
T.length Text
srvNick
else forall a. Maybe a
Nothing
forall s. Text -> IRC s ()
setNick forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> Text -> Text
trunc Maybe Int
nicklen forall a b. (a -> b) -> a -> b
$ Text -> Text
f Text
srvNick
go Text -> Text
_ [Text]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
fresh :: Text -> Text
fresh Text
n = if Text -> Int
T.length Text
n' 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 forall a. Semigroup a => a -> a -> a
<> Text
"1") forall a. a -> Maybe a -> a
`fromMaybe` Text -> Maybe Text
charsubst Text
n
trunc :: Maybe Int -> Text -> Text
trunc Maybe Int
len Text
txt = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
txt (Int -> Text -> Text
`takeEnd` Text
txt) Maybe Int
len
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
"-")
]
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) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
before forall a. Semigroup a => a -> a -> a
<> Text
to 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
_ = forall a. Maybe a
Nothing
joinHandler :: EventHandler s
joinHandler :: forall s. EventHandler s
joinHandler = forall b s.
(Event Text -> Maybe b)
-> (Source Text -> b -> IRC s ()) -> EventHandler s
EventHandler (\Event Text
ev -> forall a. Int -> Event a -> Maybe [a]
matchNumeric Int
331 Event Text
ev forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. Int -> Event a -> Maybe [a]
matchNumeric Int
332 Event Text
ev) forall a b. (a -> b) -> a -> b
$ \Source Text
_ [Text]
args -> case [Text]
args of
(Text
c:[Text]
_) -> do
TVar (InstanceConfig s)
tvarI <- forall a s. Getting a s a -> s -> a
get forall s. Lens' (IRCState s) (TVar (InstanceConfig s))
instanceConfig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. IRC s (IRCState s)
getIRCState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (InstanceConfig s)
tvarI forall a b. (a -> b) -> a -> b
$ \InstanceConfig s
iconf ->
(if Text
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a s. Getting a s a -> s -> a
get forall s. Lens' (InstanceConfig s) [Text]
channels InstanceConfig s
iconf
then forall s a. Lens' s a -> (a -> a) -> s -> s
modify forall s. Lens' (InstanceConfig s) [Text]
channels (Text
cforall a. a -> [a] -> [a]
:)
else forall a. a -> a
id) InstanceConfig s
iconf
[Text]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
kickHandler :: EventHandler s
kickHandler :: forall s. EventHandler s
kickHandler = forall b s.
(Event Text -> Maybe b)
-> (Source Text -> b -> IRC s ()) -> EventHandler s
EventHandler (forall a b. Prism' (Message a) b -> Event a -> Maybe b
matchType forall a. Prism' (Message a) (a, a, Reason a)
_Kick) forall a b. (a -> b) -> a -> b
$ \Source Text
src (Text
n, Text
_, Maybe Text
_) -> do
TVar (InstanceConfig s)
tvarI <- forall a s. Getting a s a -> s -> a
get forall s. Lens' (IRCState s) (TVar (InstanceConfig s))
instanceConfig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. IRC s (IRCState s)
getIRCState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
Text
theNick <- forall a s. Getting a s a -> s -> a
get forall s. Lens' (InstanceConfig s) Text
nick forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> STM a
readTVar TVar (InstanceConfig s)
tvarI
case Source Text
src of
Channel Text
c Text
_
| Text
n forall a. Eq a => a -> a -> Bool
== Text
theNick -> forall s. TVar (InstanceConfig s) -> Text -> STM ()
delChan TVar (InstanceConfig s)
tvarI Text
c
| Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Source Text
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
breakOn' :: Text -> Text -> Maybe (Text, Text)
breakOn' :: Text -> Text -> Maybe (Text, Text)
breakOn' Text
delim Text
txt = if Text -> Int
T.length Text
after forall a. Ord a => a -> a -> Bool
>= Text -> Int
T.length Text
delim
then forall a. a -> Maybe a
Just (Text
before, Int -> Text -> Text
T.drop (Text -> Int
T.length Text
delim) Text
after)
else forall a. Maybe a
Nothing
where
(Text
before, Text
after) = Text -> Text -> (Text, Text)
breakOn Text
delim Text
txt