lambdabot-4.1: Plugin/Base.hs
--
-- | Lambdabot base module. Controls message send and receive
--
module Plugin.Base (theModule) where
import Plugin
import IRCBase (IrcMessage, timeReply, errShowMsg)
-- import Message (getTopic, nick, joinChannel, body, fullName, channels)
import Message (getTopic, nick, server, body, Nick(..), lambdabotName, showNick, readNick)
import qualified Data.Map as M (insert, delete)
import Control.Monad.State (MonadState(..), when, gets)
import GHC.IOBase (Exception(NoMethodError))
import qualified Data.ByteString.Char8 as P
import qualified Text.Regex as R
-- valid command prefixes
commands :: [String]
commands = commandPrefixes config
PLUGIN Base
type BaseState = GlobalPrivate () ()
type Base a = ModuleT BaseState LB a
instance Module BaseModule BaseState where
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 "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 :: IrcMessage -> Base ()
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 | lambdabotName msg /= nick msg = doIGNORE msg
| otherwise
= 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
[] -> Nick "freenode" "weird#"
_ -> Nick (server msg) (tail aloc)
doPART :: Callback
doPART msg
= when (lambdabotName msg == nick msg) $ do
let loc = Nick (server msg) (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 = Nick (server msg) ((head (body msg)))
s <- get
put (s { ircChannels = M.insert (mkCN loc) (tail $ head $ tail $ body msg) (ircChannels s)})
doRPL_WELCOME :: Callback
doRPL_WELCOME = doIGNORE
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 = Nick (server msg) ((body msg) !! 1)
s <- get
put (s { ircChannels = M.insert (mkCN loc) (tail $ last $ body msg) (ircChannels s) })
doPRIVMSG :: IrcMessage -> Base ()
doPRIVMSG msg = do
-- now <- io getClockTime
-- io $ appendFile "State/log" $ ppr now
ignored <- lift $ checkIgnore msg
if ignored
then lift $ doIGNORE msg
else mapM_ (doPRIVMSG' (lambdabotName msg) msg) targets
where
alltargets = head (body msg)
targets = map (readNick msg) $ split "," alltargets
-- where
-- ppr now = concat [ timeStamp now, " ", "<", (nick msg), " ", (fullName msg), " #"
-- , (concat . intersperse "," $ channels msg) , "> "
-- , (tail . concat . intersperse " " . tail) (body msg), "\n"]
--
-- | What does the bot respond to?
--
doPRIVMSG' :: Nick -> IrcMessage -> Nick -> Base ()
doPRIVMSG' myname msg target
| myname == target
= let (cmd, params) = breakOnGlue " " text
in doPersonalMsg cmd (dropWhile (== ' ') params)
| flip any ":," $ \c -> (showNick msg myname ++ [c]) `isPrefixOf` text
= let Just wholeCmd = maybeCommand (showNick msg 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]) ||
(length text > 2 && text !! 2 == ' ')) -- ignore @@ prefix, but not the @@ command itself
= let (cmd, params) = breakOnGlue " " (dropWhile (==' ') text)
in doPublicMsg cmd (dropWhile (==' ') params)
| otherwise = doContextualMsg text
where
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
| otherwise = (lift $ doIGNORE msg)
doPublicMsg s r
| commands `arePrefixesOf` s = doMsg (tail s) r target
| (evalPrefixes config) `arePrefixesWithSpaceOf` s = doMsg "run" r target -- TODO
| otherwise = (lift $ doIGNORE msg)
--
-- 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
-> lift . ircmsg $ "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
fcmd = P.pack cmd -- TODO
frest = P.pack rest
docmd cmd' = do
act <- bindModule0 . withPS towhere $ \_ _ -> do
withModule ircCommands cmd' -- Important.
(ircPrivmsg towhere "Unknown command, try @list")
(\m -> do
name' <- getName
privs <- gets ircPrivCommands
let illegal = disabledCommands config
ok <- liftM2 (||) (return $ cmd' `notElem` (privs ++ illegal))
(lift $ checkPrivs msg)
if not ok
then lift $ ircPrivmsg towhere "Not enough privileges"
else catchIrc
(do mstrs <- catchError
(Right `fmap` fprocess_ m fcmd frest)
(\ex -> case (ex :: IRCError) of -- dispatch
(IRCRaised (NoMethodError _)) -> catchError
(Left `fmap` process m msg towhere cmd' rest)
(\ey -> case (ey :: IRCError) of -- dispatch
(IRCRaised (NoMethodError _)) ->
Left `fmap` process_ m cmd' rest
_ -> throwError ey)
_ -> throwError ex)
-- send off our strings/bytestrings
case mstrs of
Right ps -> lift $ mapM_ (ircPrivmsgF towhere) ps
Left ms -> lift $ mapM_ (ircPrivmsg towhere) ms)
(lift . ircPrivmsg towhere .
(("Plugin `" ++ name' ++ "' failed with: ") ++) . show))
lift $ act
--
-- 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 = lift $ do
withAllModules ( \m -> do
act <- bindModule0 ( do
ms <- contextual m msg target r
lift $ mapM_ (ircPrivmsg target) ms
)
name' <- getName
lift $ catchIrc act (debugStrLn . (name' ++) .
(" module failed in contextual handler: " ++) . show)
)
return ()
------------------------------------------------------------------------
maybeCommand :: String -> String -> Maybe String
maybeCommand nm text = case R.matchRegexAll re text of
Nothing -> Nothing
Just (_, _, cmd, _) -> Just cmd
where re = regex' (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 ()
-}