{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Network.IRC.Client.Events
(
EventHandler(..)
, matchCTCP
, matchNumeric
, matchType
, matchWhen
, defaultEventHandlers
, defaultOnConnect
, defaultOnDisconnect
, pingHandler
, ctcpPingHandler
, ctcpVersionHandler
, ctcpTimeHandler
, welcomeNick
, joinOnWelcome
, joinHandler
, nickMangler
, Event(..)
, Message(..)
, Source(..)
, module Network.IRC.Conduit.Lens
) where
import Control.Applicative ((<$>), (<|>))
import Control.Concurrent.STM (atomically, readTVar, modifyTVar)
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.CTCP (fromCTCP)
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
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
matchNumeric :: Int -> Event a -> Maybe [a]
matchNumeric num ev = case _message ev of
Numeric n args | num == n -> Just args
_ -> Nothing
matchType :: Prism' (Message a) b -> Event a -> Maybe b
matchType k = preview k . _message
matchWhen :: (Event a -> Bool) -> Event a -> Maybe (Message a)
matchWhen p ev | p ev = Just (_message ev)
matchWhen _ _ = Nothing
defaultEventHandlers :: [EventHandler s]
defaultEventHandlers =
[ pingHandler
, kickHandler
, ctcpPingHandler
, ctcpTimeHandler
, ctcpVersionHandler
, welcomeNick
, joinOnWelcome
, joinHandler
, nickMangler
]
defaultOnConnect :: IRC s ()
defaultOnConnect = do
iconf <- snapshot instanceConfig =<< getIRCState
send . Nick $ get nick iconf
defaultOnDisconnect :: Maybe SomeException -> IRC s ()
defaultOnDisconnect (Just exc) = case fromException exc of
Just Timeout -> reconnect
Nothing -> throwM exc
defaultOnDisconnect Nothing = pure ()
pingHandler :: EventHandler s
pingHandler = EventHandler (matchType _Ping) $ \_ (s1, s2) ->
send . Pong $ fromMaybe s1 s2
ctcpPingHandler :: EventHandler s
ctcpPingHandler = EventHandler (matchCTCP "PING") $ \src args -> case src of
User n -> send $ ctcpReply n "PING" args
_ -> pure ()
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 ()
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 ()
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 ()
joinOnWelcome :: EventHandler s
joinOnWelcome = EventHandler (matchNumeric 001) $ \_ _ -> do
iconf <- snapshot instanceConfig =<< getIRCState
mapM_ (send . Join) $ get channels iconf
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)
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
trunc len txt = maybe txt (`takeEnd` txt) len
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", "-")
]
transform ((from, to):trs) txt = case breakOn' from txt of
Just (before, after) -> Just $ before <> to <> after
_ -> transform trs txt
transform [] _ = Nothing
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 ()
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 ()
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