{-# OPTIONS -cpp #-}
--
-- | The guts of lambdabot.
--
-- The LB/Lambdabot monad
-- Generic server connection,disconnection
-- The module typeclass, type and operations on modules
--
module Lambdabot (
MODULE(..), Module(..),
ModuleT, ModState, ModuleLB, Mode(..),
IRCRState(..), IRCRWState(..), IRCError(..),
module Msg,
LB(..), lbIO,
withModule, withAllModules, getDictKeys,
send, send_,
ircPrivmsg, ircPrivmsg', -- not generally used
ircQuit, ircReconnect,
ircGetChannels,
ircSignalConnect, Callback, ircInstallOutputFilter, OutputFilter,
ircInstallModule, ircUnloadModule,
serverSignOn,
ircRead,
ircLoad, ircUnload,
checkPrivs, mkCN, handleIrc, catchIrc, runIrc,
) where
import qualified Message as Msg
import qualified Shared as S
import qualified Config (config, name, admins, host, port, Protocol(..))
import qualified IRC (IrcMessage, quit, privmsg, readerLoop
,writerLoop, offlineReaderLoop, offlineWriterLoop, user, setNick)
import Lib.Signals
import Lib.Util
import Lib.Serial
import Prelude hiding (mod, catch)
import Network (withSocketsDo, connectTo, PortID(PortNumber))
import System.Exit
import System.IO
import System.Posix.Process
import System.Posix.Signals
import Data.Char
import Data.IORef (newIORef, IORef, readIORef, writeIORef)
import Data.List (isSuffixOf, inits, tails)
import Data.Maybe (isJust)
import Data.Map (Map)
import qualified Data.Map as M hiding (Map)
import qualified Data.ByteString.Char8 as P
import Control.Concurrent
import Control.Exception
import Control.Monad.Error (MonadError (..))
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans ( liftIO )
#if __GLASGOW_HASKELL__ >= 605
import GHC.Err
#endif
------------------------------------------------------------------------
--
-- Lambdabot state
--
-- | Global read-only state.
data IRCRState
= IRCRState {
ircServer :: String,
ircReadChan :: Pipe,
ircReadThread :: ThreadId,
ircWriteChan :: Pipe,
ircWriteThread :: ThreadId
}
type Pipe = Chan (Maybe IRC.IrcMessage)
type Callback = IRC.IrcMessage -> LB ()
type OutputFilter = String -> [String] -> LB [String]
-- | Global read\/write state.
data IRCRWState = IRCRWState {
ircPrivilegedUsers :: Map String Bool,
ircChannels :: Map ChanName String,
-- ^ maps channel names to topics
ircModules :: Map String ModuleRef,
ircCallbacks :: Map String [(String,Callback)],
ircOutputFilters :: [(String,OutputFilter)],
-- ^ Output filters, invoked from right to left
ircCommands :: Map String ModuleRef,
ircPrivCommands :: [String],
ircStayConnected :: Bool,
ircDynLoad :: S.DynLoad
}
newtype ChanName = ChanName { getCN :: String } -- should be abstract, always lowercase
deriving (Eq, Ord)
instance Show ChanName where show (ChanName x) = show x
-- | only use the "smart constructor":
mkCN :: String -> ChanName
mkCN = ChanName . map toLower
-- ---------------------------------------------------------------------
--
-- The LB (LambdaBot) monad
--
-- | The IRC Monad. The reader transformer holds information about the
-- connection to the IRC server.
--
-- instances Monad, Functor, MonadIO, MonadState, MonadError
newtype LB a = LB { runLB :: ReaderT (IORef (Maybe IRCRState),IORef IRCRWState) IO a }
deriving (Monad,Functor,MonadIO)
-- Actually, this isn't a reader anymore
instance MonadReader IRCRState LB where
ask = LB $ fmap (maybe (error "No connection") id) $
io . readIORef =<< asks fst
local = error "You are not supposed to call local"
instance MonadState IRCRWState LB where
get = LB $ do
ref <- asks snd
lift $ readIORef ref
put x = LB $ do
ref <- asks snd
lift $ writeIORef ref x
-- And now a MonadError instance to map IRCErrors to MonadError in LB,
-- so throwError and catchError "just work"
instance MonadError IRCError LB where
throwError (IRCRaised e) = io $ throwIO e
throwError (SignalCaught e) = io $ evaluate (throwDyn $ SignalException e)
m `catchError` h = lbIO $ \conv -> (conv m
`catchDyn` \(SignalException e) -> conv $ h $ SignalCaught e)
`catch` \e -> conv $ h $ IRCRaised e
-- A type for handling both Haskell exceptions and external signals
data IRCError = IRCRaised Exception | SignalCaught Signal deriving Show
-- lbIO return :: LB (LB a -> IO a)
-- CPS to work around predicativiy of haskell's type system.
lbIO :: ((forall a. LB a -> IO a) -> IO b) -> LB b
lbIO k = LB . ReaderT $ \r -> k (\(LB m) -> m `runReaderT` r)
-- | Take a state, and a lambdabot monad action, run the action,
-- preserving the state before and after you run the action.
localLB :: Maybe IRCRState -> LB a -> LB a
localLB new (LB m) = LB $ do
ref <- asks fst
old <- io $ readIORef ref
io $ writeIORef ref new
res <- m
io $ writeIORef ref old
return res
-- | run a computation in the LB monad
evalLB :: LB a -> IRCRWState -> IO a
evalLB (LB lb) rws = do
ref <- newIORef rws
ref' <- newIORef Nothing
lb `runReaderT` (ref',ref)
-- May wish to add more things to the things caught, or restructure things
-- a bit. Can't just catch everything - in particular EOFs from the socket
-- loops get thrown to this thread and we musn't just ignore them.
handleIrc :: MonadError IRCError m => (IRCError -> m ()) -> m () -> m ()
handleIrc handler m = catchError m handler
-- Like handleIrc, but with arguments reversed
catchIrc :: MonadError IRCError m => m () -> (IRCError -> m ()) -> m ()
catchIrc = flip handleIrc
------------------------------------------------------------------------
--
-- Lambdabot modes, networked , or command line
--
data Mode = Online | Offline deriving Eq
--
-- | The Lambdabot entry point.
-- Initialise plugins, connect, and run the bot in the LB monad
--
-- Also, handle any fatal exceptions (such as non-recoverable signals),
-- (i.e. print a message and exit). Non-fatal exceptions should be dealt
-- with in the mainLoop or further down.
--
runIrc :: Mode -> LB a -> LB () -> S.DynLoad -> IO ()
runIrc mode initialise loop ld = withSocketsDo $ do
r <- try $ evalLB (do withDebug "Initialising plugins" initialise
withIrcSignalCatch (mainLoop mode loop))
(initState (Config.admins Config.config) ld)
-- clean up and go home
case r of
Left _ -> exitWith (ExitFailure 1) -- won't happen. exitImmediately cleans it all up
Right _ -> exitWith ExitSuccess
--
-- | Default rw state
--
initState :: [String] -> S.DynLoad -> IRCRWState
initState as ld = IRCRWState {
ircPrivilegedUsers = M.fromList $ zip as (repeat True),
ircChannels = M.empty,
ircModules = M.empty,
ircCallbacks = M.empty,
ircOutputFilters = [
([],cleanOutput),
([],lineify),
([],cleanOutput),
([],reduceIndent),
([],checkRecip) ],
ircCommands = M.empty,
ircPrivCommands = [],
ircStayConnected = True,
ircDynLoad = ld
}
--
-- Actually connect to the irc server
--
mainLoop :: Mode -> LB a -> LB ()
mainLoop mode loop = do
-- in offline mode we connect to stdin/stdout. in online mode our
-- handles are network pipes
(hin,hout,rloop,wloop) <- case mode of
Online -> do
let portnum = PortNumber $ fromIntegral (Config.port Config.config)
s <- io $ connectTo (Config.host Config.config) portnum
return (s,s,IRC.readerLoop,IRC.writerLoop)
Offline -> return (stdin, stdout, IRC.offlineReaderLoop, IRC.offlineWriterLoop)
io $ hSetBuffering hout NoBuffering
io $ hSetBuffering hin NoBuffering
threadmain <- io myThreadId
chanr <- io newChan
chanw <- io newChan
syncR <- io $ newMVar () -- used in offline to make threads synchronous
syncW <- io newEmptyMVar
threadr <- io $ forkIO $ rloop threadmain chanr chanw hin syncR syncW
threadw <- io $ forkIO $ wloop threadmain chanw hout syncR syncW
let chans = IRCRState {
ircServer = Config.host Config.config,
ircReadChan = chanr,
ircReadThread = threadr,
ircWriteChan = chanw,
ircWriteThread = threadw
}
catchIrc
(localLB (Just chans) loop >> return ())
(\e -> do -- catch anything, print informative message, and clean up
io $ hPutStrLn stderr $
(case e of
IRCRaised ex -> "Exception: " ++ show ex
SignalCaught s -> "Signal: " ++ ircSignalMessage s)
withDebug "Running exit handlers" runExitHandlers
withDebug "Writing persistent state" flushModuleState
io $ do hPutStrLn stderr "Exiting ... "
exitImmediately (ExitFailure 1))
-- throwError e)
-- | run 'exit' handler on modules
runExitHandlers:: LB ()
runExitHandlers = withAllModules moduleExit >> return ()
-- | flush state of modules
flushModuleState :: LB ()
flushModuleState = withAllModules (\m -> writeGlobalState m ?name) >> return ()
------------------------------------------------------------------------
-- | The Module type class.
-- Minimal complete definition: @moduleHelp@, @moduleCmds@, and
-- either @process@ or @process_@
class Module m s | m -> s where
-- | If the module wants its state to be saved, this function should
-- return a Serial.
--
-- The default implementation returns Nothing.
moduleSerialize :: m -> Maybe (Serial s)
-- | If the module maintains state, this method specifies the default state
-- (for example in case the state can't be read from a state).
--
-- The default implementation returns an error and assumes the state is
-- never accessed.
moduleDefState :: m -> LB s
-- | Is the module sticky? Sticky modules (as well as static ones) can't be
-- unloaded. By default, modules are not sticky.
moduleSticky :: m -> Bool
-- | The commands the module listenes to.
moduleCmds :: m -> [String]
-- | This method should return a help string for every command it defines.
moduleHelp :: m -> String -> String
-- | The privileged commands the module listenes to.
modulePrivs :: m -> [String]
-- | Initialize the module. The default implementation does nothing.
moduleInit :: m -> ModuleT s LB ()
-- | Finalize the module. The default implementation does nothing.
moduleExit :: m -> ModuleT s LB ()
-- | Process a command a user sent, the resulting string is draw in
-- some fashion. If the `process' function doesn't exist, we catch
-- an exception when we try to call it, and instead call `process_'
-- which is guaranteed to at least have a default instance.
-- This magic (well, for Haskell) occurs in Base.hs
--
process :: Msg.Message a
=> m -- ^ phantom (required)
-> a -- ^ the message (uneeded by most?)
-> String -- ^ target
-> String -- ^ command
-> String -- ^ the arguments to the command
-> ModuleLB s -- ^ maybe output
-- | Process contextual input. A plugin that implements 'contextual'
-- is able to respond to text not part of a normal command.
contextual :: Msg.Message a
=> m -- ^ phantom (required)
-> a -- ^ the message
-> String -- ^ target
-> String -- ^ the text
-> ModuleLB s -- ^ maybe output
-- | Like process, but uncommonly used args are ignored
-- Lambdabot will attempt to run process first, and then fall back
-- to process_, which in turn has a default instance.
--
process_ :: m -- ^ phantom
-> String -> String -- ^ command, args
-> ModuleLB s -- ^ maybe output
------------------------------------------------------------------------
contextual _ _ _ _ = return []
process_ _ _ _ = return []
moduleHelp m _ = concat (map ('@':) (moduleCmds m))
modulePrivs _ = []
moduleCmds _ = []
moduleExit _ = return ()
moduleInit _ = return ()
moduleSticky _ = False
moduleSerialize _ = Nothing
moduleDefState _ = return $ error "state not initalized"
-- work around weird issue in 6.5, where the missing default fails
#if __GLASGOW_HASKELL__ >= 605
process _ _ _ _ _ = GHC.Err.noMethodBindingError "Lambdabot.process"#
#endif
-- | An existential type holding a module, used to represent modules on
-- the value level, for manipluation at runtime by the dynamic linker.
--
data MODULE = forall m s. (Module m s) => MODULE m
data ModuleRef = forall m s. (Module m s) => ModuleRef m (MVar s) String
--
-- | This \"transformer\" encodes the additional information a module might
-- need to access its name or its state.
--
-- TODO: remove implicit parameters. It won't be valid Haskell'
--
type ModuleT s m a = (?ref :: MVar s, ?name :: String) => m a
-- Name !!!
type ModState s a = (?ref :: MVar s, ?name :: String) => a
-- | A nicer synonym for some ModuleT stuffs
type ModuleLB m = ModuleT m LB [String]
-- ---------------------------------------------------------------------
--
-- Handling global state
--
-- | Peristence: write the global state out
writeGlobalState :: Module m s => m -> String -> ModuleT s LB ()
writeGlobalState mod name = case moduleSerialize mod of
Nothing -> return ()
Just ser -> do
state <- io $ readMVar ?ref -- readMS
case serialize ser state of
Nothing -> return () -- do not write any state
Just out -> io $ P.writeFile (toFilename name) out
-- | Read it in
readGlobalState :: Module m s => m -> String -> IO (Maybe s)
readGlobalState mod name = case moduleSerialize mod of
Nothing -> return Nothing
Just ser -> do
state <- Just `fmap` P.readFile (toFilename name) `catch` \_ -> return Nothing
let state' = deserialize ser =<< state -- Monad Maybe
return $ maybe Nothing (Just $) state'
-- | helper
toFilename :: String -> String
toFilename = ("State/"++)
------------------------------------------------------------------------
--
-- | Register a module in the irc state
--
ircInstallModule :: MODULE -> String -> LB ()
ircInstallModule (MODULE mod) modname = do
savedState <- io $ readGlobalState mod modname
state <- maybe (moduleDefState mod) return savedState
ref <- io $ newMVar state
let modref = ModuleRef mod ref modname
-- TODO
let ?ref = ref; ?name = modname -- yikes
moduleInit mod
let cmds = moduleCmds mod
privs = modulePrivs mod
s <- get
let modmap = ircModules s
cmdmap = ircCommands s
put $ s {
ircModules = M.insert modname modref modmap,
ircCommands = addList [ (cmd,modref) | cmd <- cmds++privs ] cmdmap,
ircPrivCommands = ircPrivCommands s ++ privs
}
io $ hPutStr stderr "." >> hFlush stderr
--
-- | Unregister a module's entry in the irc state
--
ircUnloadModule :: String -> LB ()
ircUnloadModule modname = withModule ircModules modname (error "module not loaded") (\m -> do
when (moduleSticky m) $ error "module is sticky"
moduleExit m
writeGlobalState m modname
s <- get
let modmap = ircModules s
cmdmap = ircCommands s
cbs = ircCallbacks s
ofs = ircOutputFilters s
put $ s { ircCommands = M.filter (\(ModuleRef _ _ name) -> name /= modname) cmdmap }
{ ircModules = M.delete modname modmap }
{ ircCallbacks = filter ((/=modname) . fst) `fmap` cbs }
{ ircOutputFilters = filter ((/=modname) . fst) ofs }
)
--
-- | Binding to dynamic loader functions (stored as a bundle in state)
-- passed from Boot. DynamicModule goes through here to get at them.
--
ircLoad :: FilePath -> S.Symbol -> LB (S.Module, a)
ircLoad mod sym = do
s <- get
let fn = S.dynload (ircDynLoad s)
io $ (fn mod sym)
--
-- | Dynamically unload a module
--
ircUnload :: FilePath -> LB ()
ircUnload mod = do
s <- get
io $ (S.unload (ircDynLoad s)) (S.Module mod)
------------------------------------------------------------------------
ircSignalConnect :: String -> Callback -> ModuleT s LB ()
ircSignalConnect str f = do
s <- get
let cbs = ircCallbacks s
case M.lookup str cbs of -- TODO
Nothing -> put (s { ircCallbacks = M.insert str [(?name,f)] cbs})
Just fs -> put (s { ircCallbacks = M.insert str ((?name,f):fs) cbs})
ircInstallOutputFilter :: OutputFilter -> ModuleT s LB ()
ircInstallOutputFilter f =
modify $ \s ->
s { ircOutputFilters = (?name, f): ircOutputFilters s }
-- | Checks if the given user has admin permissions and excecute the action
-- only in this case.
checkPrivs :: IRC.IrcMessage -> LB Bool
checkPrivs msg = gets (isJust . M.lookup (Msg.nick msg) . ircPrivilegedUsers)
------------------------------------------------------------------------
-- Some generic server operations
serverSignOn :: Config.Protocol -> String -> String -> LB ()
serverSignOn Config.Irc nick userinfo = ircSignOn nick userinfo
serverSignOn Config.Xmpp nick _ = jabberSignOn nick
jabberSignOn :: String -> LB ()
jabberSignOn _ = undefined
ircSignOn :: String -> String -> LB ()
ircSignOn nick ircname = do
server <- asks ircServer
-- password support. TODO: Move this to IRC?
-- If plugin initialising was delayed till after we connected, we'd
-- be able to write a Passwd plugin.
send . Just $ IRC.user nick server ircname
send . Just $ IRC.setNick nick
mpasswd <- liftIO (handleJust ioErrors (const (return "")) $
readFile "State/passwd")
case readM mpasswd of
Nothing -> return ()
Just passwd -> ircPrivmsg "nickserv" $ Just $ "identify " ++ passwd
ircGetChannels :: LB [String]
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 -> LB ()
ircQuit msg = do
modify $ \state -> state { ircStayConnected = False }
send . Just $ IRC.quit msg
liftIO $ threadDelay 1000
io $ hPutStrLn stderr "Quit"
ircReconnect :: String -> LB ()
ircReconnect msg = do
send . Just $ IRC.quit msg
liftIO $ threadDelay 1000
ircRead :: LB (Maybe IRC.IrcMessage)
ircRead = do
chanr <- asks ircReadChan
liftIO (readChan chanr)
--
-- convenient wrapper
--
send_ :: IRC.IrcMessage -> LB ()
send_ = send . Just
send :: Maybe IRC.IrcMessage -> LB ()
send line = do
chanw <- asks ircWriteChan
io (writeChan chanw line)
-- | Send a message to a channel\/user. If the message is too long, the rest
-- of it is saved in the (global) more-state.
ircPrivmsg :: String -- ^ The channel\/user.
-> Maybe String -- ^ The message.
-> LB ()
ircPrivmsg who Nothing = ircPrivmsg' who Nothing
ircPrivmsg who (Just msg) = do
filters <- gets ircOutputFilters
sendlines <- foldr (\f -> (=<<) (f who)) ((return . lines) msg) $ map snd filters
mapM_ (\s -> ircPrivmsg' who (Just $ take textwidth s)) (take 10 sendlines)
-- A raw send version
ircPrivmsg' :: String -> Maybe String -> LB ()
ircPrivmsg' who (Just "") = ircPrivmsg' who (Just " ")
ircPrivmsg' who (Just msg) = send . Just $ IRC.privmsg who msg
ircPrivmsg' _ Nothing = send Nothing
------------------------------------------------------------------------
-- Module handling
-- | Interpret an expression in the context of a module.
-- Arguments are which map to use (@ircModules@ and @ircCommands@ are
-- the only sensible arguments here), the name of the module\/command,
-- action for the case that the lookup fails, action if the lookup
-- succeeds.
--
withModule :: (Ord k)
=> (IRCRWState -> Map k ModuleRef)
-> k
-> LB a
-> (forall mod s. Module mod s => mod -> ModuleT s LB a)
-> LB a
withModule dict modname def f = do
maybemod <- gets (M.lookup modname . dict)
case maybemod of
-- TODO stick this ref stuff in a monad instead. more portable in
-- the long run.
Just (ModuleRef m ref name) -> let ?ref = ref; ?name = name in f m
_ -> def
-- | Interpret a function in the context of all modules
withAllModules :: (forall mod s. Module mod s => mod -> ModuleT s LB a) -> LB [a]
withAllModules f = do
mods <- gets $ M.elems . ircModules :: LB [ModuleRef]
(`mapM` mods) $ \(ModuleRef m ref name) -> do
let ?ref = ref; ?name = name
f m
getDictKeys :: (MonadState s m) => (s -> Map k a) -> m [k]
getDictKeys dict = gets (M.keys . dict)
------------------------------------------------------------------------
-- | Print a debug message, and perform an action
withDebug :: String -> LB a -> LB ()
withDebug s a = do
io $ hPutStr stderr (s ++ " ...") >> hFlush stderr
a
io $ hPutStrLn stderr " done." >> hFlush stderr
----------------------------------------------------------------------
-- Output filters
textwidth :: Int
textwidth = 200 -- IRC maximum msg length, minus a bit for safety.
-- | For now, this just checks for duplicate empty lines.
cleanOutput :: OutputFilter
cleanOutput _ msg = return $ remDups True msg'
where
remDups True ([]:xs) = remDups True xs
remDups False ([]:xs) = []:remDups True xs
remDups _ (x: xs) = x: remDups False xs
remDups _ [] = []
msg' = map dropSpaceEnd msg
-- | wrap long lines.
lineify :: OutputFilter
lineify = const (return . mlines . unlines)
-- | break into lines
mlines :: String -> [String]
mlines = (mbreak =<<) . lines
where
mbreak :: String -> [String]
mbreak xs
| null bs = [as]
| otherwise = (as++cs) : filter (not . null) (mbreak ds)
where
(as,bs) = splitAt (w-n) xs
breaks = filter (not . isAlphaNum . last . fst) $ drop 1 $
take n $ zip (inits bs) (tails bs)
(cs,ds) = last $ (take n bs, drop n bs): breaks
w = textwidth
n = 10
-- | Don't send any output to alleged bots.
checkRecip :: OutputFilter
checkRecip who msg
| who == Config.name Config.config = return []
| "bot" `isSuffixOf` lowerCaseString who = return []
| otherwise = return msg
-- | Divide the lines' indent by two
reduceIndent :: OutputFilter
reduceIndent _ msg = return $ map redLine msg
where
redLine (' ':' ':xs) = ' ':redLine xs
redLine xs = xs