module Network.IRC.Client.Handlers
(
defaultEventHandlers
, pingHandler
, ctcpPingHandler
, ctcpVersionHandler
, ctcpTimeHandler
, welcomeNick
, joinOnWelcome
, nickMangler
, defaultOnConnect
, defaultOnDisconnect
) where
import Control.Applicative ((<$>))
import Control.Arrow (first)
import Control.Concurrent.STM (atomically, readTVar, writeTVar)
import Control.Monad (unless)
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.Client.Types
import Network.IRC.Client.Utils
import Network.IRC.Client.Internal
#if MIN_VERSION_time(1,5,0)
import Data.Time.Format (defaultTimeLocale)
#else
import System.Locale (defaultTimeLocale)
#endif
import qualified Data.Text as T
defaultEventHandlers :: [EventHandler s]
defaultEventHandlers =
[ EventHandler "Respond to server PING requests" EPing pingHandler
, EventHandler "Respond to CTCP PING requests" ECTCP ctcpPingHandler
, EventHandler "Respond to CTCP VERSION requests" ECTCP ctcpVersionHandler
, EventHandler "Respond to CTCP TIME requests" ECTCP ctcpTimeHandler
, EventHandler "Update the nick upon welcome" ENumeric welcomeNick
, EventHandler "Join channels upon welcome" ENumeric joinOnWelcome
, EventHandler "Mangle the nick on collision" ENumeric nickMangler
, EventHandler "Update the channel list on JOIN" ENumeric joinHandler
, EventHandler "Update the channel lift on KICK" EKick kickHandler
]
pingHandler :: UnicodeEvent -> StatefulIRC s ()
pingHandler ev = case _message ev of
Ping s1 s2 -> send . Pong $ fromMaybe s1 s2
_ -> return ()
ctcpPingHandler :: UnicodeEvent -> StatefulIRC s ()
ctcpPingHandler = ctcpHandler [("PING", return)]
ctcpVersionHandler :: UnicodeEvent -> StatefulIRC s ()
ctcpVersionHandler = ctcpHandler [("VERSION", go)] where
go _ = do
ver <- _ctcpVer <$> instanceConfig
return [ver]
ctcpTimeHandler :: UnicodeEvent -> StatefulIRC s ()
ctcpTimeHandler = ctcpHandler [("TIME", go)] where
go _ = do
now <- liftIO getCurrentTime
return [T.pack $ formatTime defaultTimeLocale "%c" now]
welcomeNick :: UnicodeEvent -> StatefulIRC s ()
welcomeNick = numHandler [(001, go)] where
go (srvNick:_) = do
tvarI <- instanceConfigTVar
liftIO . atomically $ do
iconf <- readTVar tvarI
writeTVar tvarI iconf { _nick = srvNick }
go _ = return ()
joinOnWelcome :: UnicodeEvent -> StatefulIRC s ()
joinOnWelcome = numHandler [(001, go)] where
go _ = do
iconf <- instanceConfig
mapM_ (send . Join) $ _channels iconf
nickMangler :: UnicodeEvent -> StatefulIRC s ()
nickMangler = numHandler [ (432, go fresh)
, (433, go mangle)
, (436, go mangle)
]
where
go f (_:srvNick:_) = do
theNick <- _nick <$> instanceConfig
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 :: UnicodeEvent -> StatefulIRC s ()
joinHandler = numHandler [(332, go)] where
go (c:_) = do
tvarI <- instanceConfigTVar
liftIO . atomically $ do
iconf <- readTVar tvarI
unless (c `elem` _channels iconf) $
writeTVar tvarI iconf { _channels = c : _channels iconf }
go _ = return ()
kickHandler :: UnicodeEvent -> StatefulIRC s ()
kickHandler ev = do
theNick <- _nick <$> instanceConfig
tvarI <- instanceConfigTVar
case (_source ev, _message ev) of
(Channel c _, Kick n _ _) | n == theNick -> liftIO . atomically $ delChan tvarI c
| otherwise -> return ()
_ -> return ()
defaultOnConnect :: StatefulIRC s ()
defaultOnConnect = do
iconf <- instanceConfig
send . Nick $ _nick iconf
defaultOnDisconnect :: StatefulIRC s ()
defaultOnDisconnect = return ()
ctcpHandler :: [(Text, [Text] -> StatefulIRC s [Text])] -> UnicodeEvent -> StatefulIRC s ()
ctcpHandler hs ev = case (_source ev, _message ev) of
(User n, Privmsg _ (Left ctcpbs)) ->
let (verb, xs) = first toUpper $ fromCTCP ctcpbs
in case lookup verb hs of
Just f -> do
args <- f xs
send $ ctcpReply n verb args
_ -> return ()
_ -> return ()
numHandler :: [(Int, [Text] -> StatefulIRC s ())] -> UnicodeEvent -> StatefulIRC s ()
numHandler hs ev = case _message ev of
Numeric num xs -> maybe (return ()) ($xs) $ lookup num hs
_ -> return ()
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