{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
-- | The guts of lambdabot.
--
-- The LB/Lambdabot monad
-- Generic server connection,disconnection
-- The module typeclass, type and operations on modules
module Lambdabot.Bot
( ircLoadModule
, ircUnloadModule
, checkPrivs
, checkIgnore
, ircCodepage
, ircGetChannels
, ircQuit
, ircReconnect
, ircPrivmsg
, ircPrivmsg'
) where
import Lambdabot.ChanName
import Lambdabot.Config
import Lambdabot.Config.Core
import Lambdabot.IRC
import Lambdabot.Logging
import Lambdabot.Message
import Lambdabot.Module
import Lambdabot.Monad
import Lambdabot.Nick
import Lambdabot.State
import Control.Concurrent
import Control.Exception.Lifted as E
import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.State
import qualified Data.Map as M
import Data.Random.Source
import qualified Data.Set as S
------------------------------------------------------------------------
--
-- | Register a module in the irc state
--
ircLoadModule :: String -> Module st -> LB ()
ircLoadModule mName m = do
infoM ("Loading module " ++ show mName)
savedState <- readGlobalState m mName
mState <- maybe (moduleDefState m) return savedState
mInfo <- registerModule mName m mState
flip runModuleT mInfo (do
moduleInit m
registerCommands =<< moduleCmds m)
`E.catch` \e@SomeException{} -> do
errorM ("Module " ++ show mName ++ " failed to load. Exception thrown: " ++ show e)
unregisterModule mName
fail "Refusing to load due to a broken plugin"
--
-- | Unregister a module's entry in the irc state
--
ircUnloadModule :: String -> LB ()
ircUnloadModule mName = do
infoM ("Unloading module " ++ show mName)
inModuleNamed mName (fail "module not loaded") $ do
m <- asks theModule
when (moduleSticky m) $ fail "module is sticky"
moduleExit m
`E.catch` \e@SomeException{} ->
errorM ("Module " ++ show mName ++ " threw the following exception in moduleExit: " ++ show e)
writeGlobalState
unregisterModule mName
------------------------------------------------------------------------
-- | Checks whether the given user has admin permissions
checkPrivs :: IrcMessage -> LB Bool
checkPrivs msg = gets (S.member (nick msg) . ircPrivilegedUsers)
-- | Checks whether the given user is being ignored.
-- Privileged users can't be ignored.
checkIgnore :: IrcMessage -> LB Bool
checkIgnore msg = liftM2 (&&) (liftM not (checkPrivs msg))
(gets (S.member (nick msg) . ircIgnoredUsers))
------------------------------------------------------------------------
-- Some generic server operations
-- Send a CODEPAGE command to set encoding for current session.
-- Some IRC networks don't provide UTF-8 ports, but allow
-- switching it in runtime
ircCodepage :: String -> String -> LB ()
ircCodepage svr cpage = do
send $ codepage svr cpage
ircGetChannels :: LB [Nick]
ircGetChannels = (map getCN . M.keys) `fmap` gets ircChannels
-- Send a quit message, settle and wait for the server to drop our
-- handle. At which point the main thread gets a closed handle eof
-- exceptoin, we clean up and go home
ircQuit :: String -> String -> LB ()
ircQuit svr msg = do
modify $ \state' -> state' { ircPersists = M.delete svr $ ircPersists state' }
send $ quit svr msg
liftIO $ threadDelay 1000
noticeM "Quitting"
ircReconnect :: String -> String -> LB ()
ircReconnect svr msg = do
modify $ \state' -> state' { ircPersists = M.insertWith (flip const) svr False $ ircPersists state' }
send $ quit svr msg
liftIO $ threadDelay 1000
-- | Send a message to a channel\/user, applying all output filters
ircPrivmsg :: Nick -- ^ The channel\/user.
-> String -- ^ The message.
-> LB ()
ircPrivmsg who msg = do
sendlines <- applyOutputFilters who msg
w <- getConfig textWidth
mapM_ (\s -> ircPrivmsg' who (take w s)) (take 10 sendlines)
-- A raw send version (bypasses output filters)
ircPrivmsg' :: Nick -> String -> LB ()
ircPrivmsg' who "" = ircPrivmsg' who " "
ircPrivmsg' who msg = send $ privmsg who msg
------------------------------------------------------------------------
monadRandom [d|
instance MonadRandom LB where
getRandomWord8 = liftIO getRandomWord8
getRandomWord16 = liftIO getRandomWord16
getRandomWord32 = liftIO getRandomWord32
getRandomWord64 = liftIO getRandomWord64
getRandomDouble = liftIO getRandomDouble
getRandomNByteInteger n = liftIO (getRandomNByteInteger n)
|]