lambdabot-4.0: Plugin/Base.hs
--
-- | Lambdabot base module. Controls message send and receive
--
module Plugin.Base (theModule) where
import Plugin
import IRC (IrcMessage, timeReply, errShowMsg)
import Message (getTopic, nick, joinChannel, body)
import qualified Data.Map as M (insert, delete)
import Control.Monad.State (MonadState(..), when, gets)
import GHC.IOBase (Exception(NoMethodError))
-- valid command prefixes
commands :: [String]
commands = commandPrefixes config
PLUGIN Base
type BaseState = GlobalPrivate () ()
instance Module BaseModule BaseState where
moduleDefState _ = return $ mkGlobalPrivate 20 ()
moduleInit _ = do
ircSignalConnect "PING" doPING
ircSignalConnect "NOTICE" doNOTICE
ircSignalConnect "PART" doPART
ircSignalConnect "JOIN" doJOIN
ircSignalConnect "NICK" doNICK
ircSignalConnect "MODE" doMODE
ircSignalConnect "TOPIC" doTOPIC
ircSignalConnect "QUIT" doQUIT
ircSignalConnect "PRIVMSG" doPRIVMSG
ircSignalConnect "001" doRPL_WELCOME
{- ircSignalConnect "002" doRPL_YOURHOST
ircSignalConnect "003" doRPL_CREATED
ircSignalConnect "004" doRPL_MYINFO -}
ircSignalConnect "005" doRPL_BOUNCE
{- ircSignalConnect "250" doRPL_STATSCONN
ircSignalConnect "251" doRPL_LUSERCLIENT
ircSignalConnect "252" doRPL_LUSEROP
ircSignalConnect "253" doRPL_LUSERUNKNOWN
ircSignalConnect "254" doRPL_LUSERCHANNELS
ircSignalConnect "255" doRPL_LUSERME
ircSignalConnect "265" doRPL_LOCALUSERS
ircSignalConnect "266" doRPL_GLOBALUSERS -}
ircSignalConnect "332" doRPL_TOPIC
{- ircSignalConnect "353" doRPL_NAMRELY
ircSignalConnect "366" doRPL_ENDOFNAMES
ircSignalConnect "372" doRPL_MOTD
ircSignalConnect "375" doRPL_MOTDSTART
ircSignalConnect "376" doRPL_ENDOFMOTD -}
doIGNORE :: Callback
doIGNORE msg = debugStrLn $ show msg
-- = debugStrLn $ "IGNORING> <" ++ msgPrefix msg ++
-- "> [" ++ msgCommand msg ++ "] " ++ show (body msg)
doPING :: Callback
doPING msg
= debugStrLn $ errShowMsg msg
-- If this is a "TIME" then we need to pass it over to the localtime plugin
-- otherwise, dump it to stdout
doNOTICE :: ModState BaseState Callback
doNOTICE msg =
if isCTCPTimeReply
then do
-- bind implicit params to Localtime module. boo on implict params :/
-- withModule ircModules
-- "Localtime"
-- (error "Plugin/Base: no Localtime plugin? So I can't handle CTCP time messges")
-- (\_ -> doPRIVMSG (timeReply msg))
-- need to say which module to run the privmsg in
doPRIVMSG (timeReply msg)
else debugStrLn $ "NOTICE: " ++ show (body msg)
where
isCTCPTimeReply = ":\SOHTIME" `isPrefixOf` (last (body msg))
doJOIN :: Callback
doJOIN msg
= do s <- get
put (s { ircChannels = M.insert (mkCN loc) "[currently unknown]" (ircChannels s)}) -- the empty topic causes problems
send_ $ getTopic loc -- initialize topic
where (_, aloc) = breakOnGlue ":" (head (body msg))
loc = case aloc of
[] -> []
_ -> tail aloc
doPART :: Callback
doPART msg
= when (name config == nick msg) $ do
let loc = head (body msg)
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 = (head (body msg))
s <- get
put (s { ircChannels = M.insert (mkCN loc) (tail $ head $ tail $ body msg) (ircChannels s)})
doRPL_WELCOME :: Callback
doRPL_WELCOME _msg = mapM_ (send_ . joinChannel) (autojoin config)
doQUIT :: Callback
doQUIT msg = doIGNORE msg
doRPL_BOUNCE :: Callback
doRPL_BOUNCE _msg = debugStrLn "BOUNCE!"
doRPL_TOPIC :: Callback
doRPL_TOPIC msg -- nearly the same as doTOPIC but has our nick on the front of body
= do let loc = (body msg) !! 1
s <- get
put (s { ircChannels = M.insert (mkCN loc) (tail $ last $ body msg) (ircChannels s) })
doPRIVMSG :: ModState BaseState Callback
doPRIVMSG msg = do
debugStrLn (show msg)
doPRIVMSG' (name config) msg
--
-- | What does the bot respond to?
--
doPRIVMSG' :: String -> IRC.IrcMessage -> ModuleT BaseState LB ()
doPRIVMSG' myname msg
| myname `elem` targets
= let (cmd, params) = breakOnGlue " " text
in doPersonalMsg cmd (dropWhile (== ' ') params)
| flip any ":," $ \c -> (myname ++ [c]) `isPrefixOf` text
= let Just wholeCmd = maybeCommand myname text
(cmd, params) = breakOnGlue " " wholeCmd
in doPublicMsg cmd (dropWhile (==' ') params)
| (commands `arePrefixesOf` text) && length text > 1
&& (text !! 1 /= ' ') -- elem of prefixes
&& (not (commands `arePrefixesOf` [text !! 1]))
= let (cmd, params) = breakOnGlue " " (dropWhile (==' ') text)
in doPublicMsg cmd (dropWhile (==' ') params)
{-
-- special syntax for @run
| evals `arePrefixesWithSpaceOf` text
= let expr = drop 2 text
in doPublicMsg "@run" (dropWhile (==' ') expr)
-}
-- send to all modules for contextual processing
| otherwise = doContextualMsg text
where
alltargets = head (body msg)
targets = split "," alltargets
text = tail (head (tail (body msg)))
who = nick msg
doPersonalMsg s r
| commands `arePrefixesOf` s = doMsg (tail s) r who
| s `elem` (evalPrefixes config) = doMsg "run" r who -- TODO
| otherwise = doIGNORE msg -- contextual?
doPublicMsg s r
| commands `arePrefixesOf` s = doMsg (tail s) r alltargets
| (evalPrefixes config) `arePrefixesWithSpaceOf` s = doMsg "run" r alltargets -- TODO
| otherwise = doIGNORE msg -- contextual?
--
-- normal commands.
--
-- check privledges, do any spell correction, dispatch, handling
-- possible timeouts.
--
-- todo, refactor
--
doMsg cmd rest towhere = do
let ircmsg = ircPrivmsg towhere
allcmds <- getDictKeys ircCommands
let ms = filter (isPrefixOf cmd) allcmds
case ms of
[s] -> docmd s -- a unique prefix
_ | cmd `elem` ms -> docmd cmd -- correct command (usual case)
_ | otherwise -> case closests cmd allcmds of
(n,[s]) | n < e , ms == [] -> docmd s -- unique edit match
(n,ss) | n < e || ms /= [] -- some possibilities
-> ircmsg . Just $ "Maybe you meant: "++showClean(nub(ms++ss))
_ -> docmd cmd -- no prefix, edit distance too far
where
e = 3 -- edit distance cut off. Seems reasonable for small words
docmd cmd' =
forkLB $ withPS towhere $ \_ _ -> do
withModule ircCommands cmd' -- Important.
(ircPrivmsg towhere (Just "Unknown command, try @list"))
(\m -> do
privs <- gets ircPrivCommands
ok <- liftM2 (||) (return $ cmd' `notElem` privs)
(checkPrivs msg)
if not ok
then ircPrivmsg towhere $ Just "Not enough privileges"
else catchIrc
(do mstrs <- catchError
(process m msg towhere cmd' rest)
(\ex -> case (ex :: IRCError) of -- dispatch
(IRCRaised (NoMethodError _)) ->
process_ m cmd' rest
_ -> throwError ex)
case mstrs of
[] -> ircPrivmsg towhere Nothing
_ -> mapM_ (ircPrivmsg towhere . Just) mstrs)
(ircPrivmsg towhere . Just .((?name++" module failed: ")++).show))
--
-- contextual messages are all input that isn't an explicit command.
-- they're passed to all modules (todo, sounds inefficient) for
-- scanning, and any that implement 'contextual' will reply.
--
-- we try to run the contextual functions from all modules, on every
-- non-command. better hope this is efficient.
--
-- Note how we catch any plugin errors here, rather than letting
-- them bubble back up to the mainloop
--
doContextualMsg r = do
withAllModules (\m ->
forkLB $ catchIrc
(do ms <- contextual m msg alltargets r
mapM_ (ircPrivmsg alltargets . Just) ms)
(\e -> debugStrLn
(?name++" module failed in contextual handler: "++show e)) )
return ()
------------------------------------------------------------------------
maybeCommand :: String -> String -> Maybe String
maybeCommand nm text = case matchRegexAll re text of
Nothing -> Nothing
Just (_, _, cmd, _) -> Just cmd
where re = mkRegex (nm ++ "[.:,]*[[:space:]]*")
--
-- And stuff we don't care about
--
{-
doRPL_YOURHOST :: Callback
doRPL_YOURHOST _msg = return ()
doRPL_CREATED :: Callback
doRPL_CREATED _msg = return ()
doRPL_MYINFO :: Callback
doRPL_MYINFO _msg = return ()
doRPL_STATSCONN :: Callback
doRPL_STATSCONN _msg = return ()
doRPL_LUSERCLIENT :: Callback
doRPL_LUSERCLIENT _msg = return ()
doRPL_LUSEROP :: Callback
doRPL_LUSEROP _msg = return ()
doRPL_LUSERUNKNOWN :: Callback
doRPL_LUSERUNKNOWN _msg = return ()
doRPL_LUSERCHANNELS :: Callback
doRPL_LUSERCHANNELS _msg = return ()
doRPL_LUSERME :: Callback
doRPL_LUSERME _msg = return ()
doRPL_LOCALUSERS :: Callback
doRPL_LOCALUSERS _msg = return ()
doRPL_GLOBALUSERS :: Callback
doRPL_GLOBALUSERS _msg = return ()
doUNKNOWN :: Callback
doUNKNOWN msg
= debugStrLn $ "UNKNOWN> <" ++ msgPrefix msg ++
"> [" ++ msgCommand msg ++ "] " ++ show (body msg)
doRPL_NAMREPLY :: Callback
doRPL_NAMREPLY _msg = return ()
doRPL_ENDOFNAMES :: Callback
doRPL_ENDOFNAMES _msg = return ()
doRPL_MOTD :: Callback
doRPL_MOTD _msg = return ()
doRPL_MOTDSTART :: Callback
doRPL_MOTDSTART _msg = return ()
doRPL_ENDOFMOTD :: Callback
doRPL_ENDOFMOTD _msg = return ()
-}