module Lambdabot.Plugin.Base (base) where
import Lambdabot
import Lambdabot.Command
import Lambdabot.Config.Core
import Lambdabot.IRC
import Lambdabot.Logging
import Lambdabot.Message
import Lambdabot.Monad
import Lambdabot.Nick
import Lambdabot.Plugin
import Lambdabot.Util
import Control.Applicative
import Control.Exception.Lifted as E
import Control.Monad
import Control.Monad.State
import Data.List
import Data.List.Split
import qualified Data.Map as M
import Text.EditDistance
import Text.Regex.TDFA
type BaseState = GlobalPrivate () ()
type Base = ModuleT BaseState LB
base :: Module (GlobalPrivate () ())
base = newModule
{ moduleDefState = return $ mkGlobalPrivate 20 ()
, moduleInit = do
ircSignalConnect "PING" doPING
bindModule1 doNOTICE >>= ircSignalConnect "NOTICE"
ircSignalConnect "PART" doPART
ircSignalConnect "JOIN" doJOIN
ircSignalConnect "NICK" doNICK
ircSignalConnect "MODE" doMODE
ircSignalConnect "TOPIC" doTOPIC
ircSignalConnect "QUIT" doQUIT
bindModule1 doPRIVMSG >>= ircSignalConnect "PRIVMSG"
ircSignalConnect "001" doRPL_WELCOME
ircSignalConnect "005" doRPL_BOUNCE
ircSignalConnect "332" doRPL_TOPIC
}
doIGNORE :: Callback
doIGNORE = debugM . show
doPING :: Callback
doPING = debugM . errShowMsg
doNOTICE :: IrcMessage -> Base ()
doNOTICE msg
| isCTCPTimeReply = doPRIVMSG (timeReply msg)
| otherwise = noticeM (show body)
where
body = ircMsgParams msg
isCTCPTimeReply = ":\SOHTIME" `isPrefixOf` (last body)
doJOIN :: Callback
doJOIN msg | lambdabotName msg /= nick msg = doIGNORE msg
| otherwise
= do s <- get
put (s { ircChannels = M.insert (mkCN loc) "[currently unknown]" (ircChannels s)})
send $ getTopic loc
where aloc = dropWhile (/= ':') (head (ircMsgParams msg))
loc = case aloc of
[] -> Nick "freenode" "weird#"
_ -> Nick (server msg) (tail aloc)
doPART :: Callback
doPART msg
= when (lambdabotName msg == nick msg) $ do
let body = ircMsgParams msg
loc = Nick (server msg) (head body)
s <- get
put (s { ircChannels = M.delete (mkCN loc) (ircChannels s) })
doNICK :: Callback
doNICK msg
= doIGNORE msg
doMODE :: Callback
doMODE msg
= doIGNORE msg
doTOPIC :: Callback
doTOPIC msg
= do let loc = Nick (server msg) (head (ircMsgParams msg))
s <- get
put (s { ircChannels = M.insert (mkCN loc) (tail $ head $ tail $ ircMsgParams msg) (ircChannels s)})
doRPL_WELCOME :: Callback
doRPL_WELCOME = doIGNORE
doQUIT :: Callback
doQUIT msg = doIGNORE msg
doRPL_BOUNCE :: Callback
doRPL_BOUNCE _msg = debugM "BOUNCE!"
doRPL_TOPIC :: Callback
doRPL_TOPIC msg
= do let body = ircMsgParams msg
loc = Nick (server msg) (body !! 1)
s <- get
put (s { ircChannels = M.insert (mkCN loc) (tail $ last body) (ircChannels s) })
doPRIVMSG :: IrcMessage -> Base ()
doPRIVMSG msg = do
ignored <- lift $ checkIgnore msg
commands <- getConfig commandPrefixes
evPrefixes <- getConfig evalPrefixes
disabled <- getConfig disabledCommands
let conf = (commands, evPrefixes, disabled)
if ignored
then lift $ doIGNORE msg
else mapM_ (doPRIVMSG' conf (lambdabotName msg) msg) targets
where
alltargets = head (ircMsgParams msg)
targets = map (parseNick (ircMsgServer msg)) $ splitOn "," alltargets
doPRIVMSG' :: ([String], [String], [String]) -> Nick -> IrcMessage -> Nick -> Base ()
doPRIVMSG' configu myname msg target
| myname == target
= let (cmd, params) = splitFirstWord text
in doPersonalMsg cmd params
| flip any ":," $ \c -> (fmtNick (ircMsgServer msg) myname ++ [c]) `isPrefixOf` text
= let Just wholeCmd = maybeCommand (fmtNick (ircMsgServer msg) myname) text
(cmd, params) = splitFirstWord wholeCmd
in doPublicMsg cmd params
| (commands `arePrefixesOf` text)
&& length text > 1
&& (text !! 1 /= ' ')
&& (not (commands `arePrefixesOf` [text !! 1]) ||
(length text > 2 && text !! 2 == ' '))
= let (cmd, params) = splitFirstWord (dropWhile (==' ') text)
in doPublicMsg cmd params
| otherwise = doContextualMsg text
where
text = tail (head (tail (ircMsgParams msg)))
who = nick msg
(commands, evPrefixes, disabled) = configu
doPersonalMsg s r
| commands `arePrefixesOf` s = doMsg (tail s) r who
| s `elem` evPrefixes = doMsg "run" r who
| otherwise = (lift $ doIGNORE msg)
doPublicMsg s r
| commands `arePrefixesOf` s = doMsg (tail s) r target
| evPrefixes `arePrefixesWithSpaceOf` s = doMsg "run" r target
| otherwise = (lift $ doIGNORE msg)
doMsg cmd rest towhere = do
let ircmsg = ircPrivmsg towhere
allcmds <- lift (gets (M.keys . ircCommands))
let ms = filter (isPrefixOf cmd) allcmds
case ms of
[s] -> docmd s
_ | cmd `elem` ms -> docmd cmd
_ | otherwise -> case closests cmd allcmds of
(n,[s]) | n < e , ms == [] -> docmd s
(n,ss) | n < e || ms /= []
-> lift . ircmsg $ "Maybe you meant: "++showClean(nub(ms++ss))
_ -> docmd cmd
where
e = 3
docmd cmd' = withPS towhere $ \_ _ -> do
withCommand cmd'
(ircPrivmsg towhere "Unknown command, try @list")
(\_ theCmd -> do
name' <- getModuleName
hasPrivs <- lb (checkPrivs msg)
let ok = (cmd' `notElem` disabled)
&& (not (privileged theCmd) || hasPrivs)
if not ok
then lift $ ircPrivmsg towhere "Not enough privileges"
else E.catch
(do mstrs <- runCommand theCmd msg towhere cmd' rest
lift $ mapM_ (ircPrivmsg towhere . expandTab 8) mstrs)
(\exc@SomeException{} -> lift . ircPrivmsg towhere .
(("Plugin `" ++ name' ++ "' failed with: ") ++) $ show exc))
doContextualMsg r = lift $ withAllModules $ \m -> do
name' <- getModuleName
E.catch
(lift . mapM_ (ircPrivmsg target) =<< execCmd (contextual m r) msg target "contextual")
(\e@SomeException{} -> debugM . (name' ++) . (" module failed in contextual handler: " ++) $ show e)
closests :: String -> [String] -> (Int,[String])
closests pat ss = M.findMin m
where
m = M.fromListWith (++) ls
ls = [ (levenshteinDistance defaultEditCosts pat s, [s]) | s <- ss ]
maybeCommand :: String -> String -> Maybe String
maybeCommand nm text = mrAfter <$> matchM re text
where
re :: Regex
re = makeRegex (nm ++ "[.:,]*[[:space:]]*")