Moved files around as a preliminary for architectural changes.
This commit is contained in:
Julien Dessaux
parent
d97177ce3b
commit
11c2c16835
29 changed files with 17 additions and 0 deletions
|
|
@ -1,9 +0,0 @@
|
|||
module Hsbot.Config
|
||||
( BotConfig (..)
|
||||
) where
|
||||
|
||||
import Hsbot.Irc.Config
|
||||
|
||||
-- | Configuration data type
|
||||
data BotConfig = IrcBotConfig IrcConfig
|
||||
|
||||
|
|
@ -1,91 +0,0 @@
|
|||
module Hsbot.Core
|
||||
( hsbot
|
||||
) where
|
||||
|
||||
import Control.Concurrent.Chan
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Exception
|
||||
import Control.Monad.State
|
||||
import qualified Data.Map as M
|
||||
import Data.Time
|
||||
import Prelude hiding (catch)
|
||||
import System.IO()
|
||||
import System.Posix.Signals
|
||||
|
||||
import Hsbot.Config
|
||||
import Hsbot.Message
|
||||
import Hsbot.Plugin
|
||||
import Hsbot.Types
|
||||
|
||||
-- | Bot's main entry point
|
||||
hsbot :: [BotConfig] -> Maybe String -> IO ()
|
||||
hsbot config txtResumeData= do
|
||||
let resumeData = case txtResumeData of
|
||||
Just txtData -> read txtData :: BotResumeData -- TODO : catch exception
|
||||
Nothing -> M.empty :: BotResumeData
|
||||
startTime <- case M.lookup "HSBOT" resumeData of
|
||||
Just hsbotData -> do
|
||||
case M.lookup "STARTTIME" hsbotData of
|
||||
Just txtStartTime -> do
|
||||
let gotStartTime = read txtStartTime :: UTCTime
|
||||
return gotStartTime
|
||||
Nothing -> getCurrentTime
|
||||
Nothing -> getCurrentTime
|
||||
let resumeData' = M.insert "HSBOT" (M.singleton "STARTTIME" $ show startTime) resumeData
|
||||
putStrLn "[Hsbot] Opening communication channel... "
|
||||
chan <- newChan :: IO (Chan BotMsg)
|
||||
mvar <- newMVar resumeData' :: IO (MVar BotResumeData)
|
||||
putStrLn "[Hsbot] Installing signal handlers... "
|
||||
_ <- installHandler sigHUP (Catch $ sigHupHandler chan) Nothing
|
||||
_ <- installHandler sigTERM (Catch $ sigTermHandler chan) Nothing
|
||||
putStrLn "[Hsbot] Spawning IrcBot plugins... "
|
||||
botState <- execStateT spawnPlugins BotState { botStartTime = startTime
|
||||
, botPlugins = M.empty
|
||||
, botChan = chan
|
||||
, botConfig = config
|
||||
, botResumeData = mvar }
|
||||
putStrLn "[Hsbot] Entering main loop... "
|
||||
(status, botState') <- runLoop botState
|
||||
putStrLn "[Hsbot] Killing active plugins... "
|
||||
newResumeData <- takeMVar mvar
|
||||
evalStateT (mapM_ killPlugin $ M.keys newResumeData) botState'
|
||||
if status == BotReboot
|
||||
then hsbot config (Just $ show newResumeData) -- TODO : exec on the hsbot launcher with the reload string
|
||||
else return ()
|
||||
where
|
||||
runLoop :: BotState -> IO (BotStatus, BotState)
|
||||
runLoop botState = do
|
||||
(status, botState') <- (runStateT botCore botState) `catches` [ Handler (\ (_ :: IOException) -> return (BotExit, botState))
|
||||
, Handler (\ (_ :: AsyncException) -> return (BotExit, botState)) ]
|
||||
case status of
|
||||
BotContinue -> runLoop botState'
|
||||
_ -> return (status, botState')
|
||||
|
||||
-- | Run the bot main loop
|
||||
botCore :: Bot (BotStatus)
|
||||
botCore = do
|
||||
chan <- gets botChan
|
||||
msg <- liftIO $ readChan chan
|
||||
case msg of
|
||||
IntMsg intMsg -> processInternalMessage intMsg
|
||||
UpdMsg updMsg -> processUpdateMessage updMsg
|
||||
RebMsg rebMsg -> processRebootMessage rebMsg
|
||||
ExiMsg exiMsg -> processExitMessage exiMsg
|
||||
|
||||
-- | Process an update command
|
||||
processUpdateMessage :: ResumeMsg -> Bot (BotStatus)
|
||||
processUpdateMessage msg = do
|
||||
resumeData <- gets botResumeData
|
||||
let from = resMsgFrom msg
|
||||
stuff = resMsgData msg
|
||||
liftIO $ modifyMVar_ resumeData (\oldData -> return $ M.insert from stuff oldData)
|
||||
return BotContinue
|
||||
|
||||
-- | signals handlers
|
||||
sigHupHandler :: Chan BotMsg -> IO ()
|
||||
sigHupHandler chan = writeChan chan $ RebMsg RebootMsg { rebMsgFrom = "HUP handler" }
|
||||
|
||||
-- | signals handlers
|
||||
sigTermHandler :: Chan BotMsg -> IO ()
|
||||
sigTermHandler chan = writeChan chan $ ExiMsg ExitMsg { exiMsgFrom = "TERM handler" }
|
||||
|
||||
|
|
@ -1,74 +0,0 @@
|
|||
module Hsbot.Irc.Command
|
||||
( processInternalCommand
|
||||
, registerCommand
|
||||
, unregisterCommand
|
||||
) where
|
||||
|
||||
import Control.Monad.State
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
|
||||
import Hsbot.Irc.Message
|
||||
import Hsbot.Irc.Plugin
|
||||
import Hsbot.Irc.Types
|
||||
import Hsbot.Types
|
||||
|
||||
-- | Registers a plugin's command
|
||||
registerCommand :: String -> String -> IrcBot ()
|
||||
registerCommand cmd pluginName' = do
|
||||
ircBot <- get
|
||||
let cmds = ircBotCommands ircBot
|
||||
plugins = ircBotPlugins ircBot
|
||||
case M.lookup pluginName' plugins of
|
||||
Just _ -> let pluginNames = pluginName' : fromMaybe [] (M.lookup cmd cmds) -- TODO : remove/check for duplicates ?
|
||||
newCmds = M.insert cmd pluginNames cmds
|
||||
in put $ ircBot { ircBotCommands = newCmds }
|
||||
Nothing -> return ()
|
||||
|
||||
-- | Unregisters a plugin's command
|
||||
unregisterCommand :: String -> String -> IrcBot ()
|
||||
unregisterCommand cmd pluginName' = do
|
||||
ircBot <- get
|
||||
let cmds = ircBotCommands ircBot
|
||||
newCmds = M.adjust (L.delete pluginName') cmd cmds
|
||||
put $ ircBot { ircBotCommands = newCmds }
|
||||
|
||||
-- | Processes an internal command
|
||||
processInternalCommand :: IrcBotMsg -> IrcBot (BotStatus)
|
||||
processInternalCommand (IntIrcCmd ircCmd)
|
||||
| ircCmdTo ircCmd == "CORE" = processCoreCommand ircCmd
|
||||
| otherwise = do
|
||||
plugins <- gets ircBotPlugins
|
||||
case M.lookup (ircCmdTo ircCmd) plugins of
|
||||
Just (plugin, _, _) -> sendToPlugin (IntIrcCmd ircCmd) plugin
|
||||
Nothing -> return ()
|
||||
return BotContinue
|
||||
processInternalCommand _ = return (BotContinue)
|
||||
|
||||
-- | Processes a core command
|
||||
processCoreCommand :: IrcCmd -> IrcBot (BotStatus)
|
||||
processCoreCommand ircCmd = do
|
||||
let command' = ircCmdCmd ircCmd
|
||||
originalRequest = ircCmdBotMsg ircCmd
|
||||
case command' of
|
||||
"LIST" -> listPlugins originalRequest (ircCmdFrom ircCmd)
|
||||
"LOAD" -> loadIrcPlugin $ ircCmdMsg ircCmd
|
||||
"REGISTER" -> registerCommand (ircCmdMsg ircCmd) (ircCmdFrom ircCmd)
|
||||
"UNLOAD" -> unloadIrcPlugin $ ircCmdMsg ircCmd
|
||||
"UNREGISTER" -> unregisterCommand (ircCmdMsg ircCmd) (ircCmdFrom ircCmd)
|
||||
"UPDATE" -> processUpdateCommand ircCmd
|
||||
_ -> return ()
|
||||
if command' == "REBOOT"
|
||||
then return BotReboot
|
||||
else return BotContinue
|
||||
|
||||
-- | Process an update command
|
||||
processUpdateCommand :: IrcCmd -> IrcBot ()
|
||||
processUpdateCommand ircCmd = do
|
||||
ircbot <- get
|
||||
let oldData = ircBotResumeData ircbot
|
||||
from = ircCmdFrom ircCmd
|
||||
stuff = ircCmdMsg ircCmd
|
||||
put $ ircbot { ircBotResumeData = M.insert from stuff oldData }
|
||||
|
||||
|
|
@ -1,34 +0,0 @@
|
|||
module Hsbot.Irc.Config
|
||||
( IrcConfig(..)
|
||||
, ircDefaultConfig
|
||||
) where
|
||||
|
||||
import Network
|
||||
|
||||
-- | Configuration data type
|
||||
data IrcConfig = IrcConfig
|
||||
{ ircConfigName :: String -- The configuration name
|
||||
, ircConfigAddress :: String -- the server's address
|
||||
, ircConfigPort :: PortID -- the server's port
|
||||
, ircConfigChannels :: [String] -- the Channels to join on start
|
||||
, ircConfigNickname :: String -- the hsbot's nickname
|
||||
, ircConfigPassword :: String -- the hsbot's password, optional
|
||||
, ircConfigRealname :: String -- the hsbot's real name, optional
|
||||
, ircConfigCommandPrefix :: Char -- the prefix the ircbot will recognize as commands
|
||||
, ircConfigPlugins :: [String] -- the ircPlugins to load
|
||||
}
|
||||
|
||||
-- | User configuration
|
||||
ircDefaultConfig :: IrcConfig
|
||||
ircDefaultConfig = IrcConfig
|
||||
{ ircConfigName = "irc-alocalhost"
|
||||
, ircConfigAddress = "localhost"
|
||||
, ircConfigPort = PortNumber 6667
|
||||
, ircConfigChannels = ["#hsbot"]
|
||||
, ircConfigNickname = "hsbot"
|
||||
, ircConfigPassword = ""
|
||||
, ircConfigRealname = "The One True bot, with it's haskell soul."
|
||||
, ircConfigCommandPrefix = '@'
|
||||
, ircConfigPlugins = ["Ping"]
|
||||
}
|
||||
|
||||
|
|
@ -1,177 +0,0 @@
|
|||
module Hsbot.Irc.Core
|
||||
( startIrcbot
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Exception (AsyncException, Handler (..), IOException, catch, catches)
|
||||
import Control.Monad.State
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Network
|
||||
import Prelude hiding (catch)
|
||||
import System.IO
|
||||
import System.Posix.IO (fdToHandle, handleToFd)
|
||||
import System.Posix.Types (Fd)
|
||||
|
||||
import Hsbot.Irc.Command
|
||||
import Hsbot.Irc.Config
|
||||
import Hsbot.Irc.Message
|
||||
import Hsbot.Irc.Plugin
|
||||
import Hsbot.Irc.Server
|
||||
import Hsbot.Irc.Types
|
||||
import Hsbot.Types
|
||||
|
||||
-- | IrcBot's main entry point
|
||||
startIrcbot :: IrcConfig -> Chan BotMsg -> Chan BotMsg -> Maybe String -> IO ()
|
||||
startIrcbot config masterChan myChan txtResumeData = do
|
||||
let resumeData = case txtResumeData of
|
||||
Just txtData -> read txtData :: ResumeData -- TODO : catch exception
|
||||
Nothing -> M.empty :: ResumeData
|
||||
print resumeData
|
||||
putStrLn "[IrcBot] Opening communication channel... "
|
||||
chan <- newChan :: IO (Chan IrcBotMsg)
|
||||
handle <- case M.lookup "HANDLE" resumeData of
|
||||
Just txtFd -> do
|
||||
let fd = read txtFd :: Fd
|
||||
fdToHandle fd
|
||||
Nothing -> do
|
||||
putStrLn $ concat ["[IrcBot] Connecting to ", ircConfigAddress config, "... "]
|
||||
handle <- connectTo (ircConfigAddress config) (ircConfigPort config)
|
||||
hSetBuffering handle NoBuffering
|
||||
hSetEncoding handle utf8
|
||||
return handle
|
||||
fd <- handleToFd handle
|
||||
putStrLn "[IrcBot] Spawning reader threads..."
|
||||
myOwnThreadId <- myThreadId
|
||||
readerThreadId <- forkIO $ ircBotReader handle chan myOwnThreadId
|
||||
masterReaderThreadId <- forkIO $ ircBotMasterReader myChan chan
|
||||
putStrLn "[IrcBot] Initializing server connection..."
|
||||
let ircServerState = IrcServerState { ircServerId = ircConfigAddress config
|
||||
, ircServerChannels = []
|
||||
, ircServerNickname = ircConfigNickname config
|
||||
, ircServerCommandPrefix = ircConfigCommandPrefix config
|
||||
, ircServerChan = chan }
|
||||
ircBotState = IrcBotState { ircBotPlugins = M.empty
|
||||
, ircBotCommands = M.empty
|
||||
, ircBotChan = chan
|
||||
, ircBotMasterChan = masterChan
|
||||
, ircBotServerState = ircServerState
|
||||
, ircBotHandle = handle
|
||||
, ircBotConfig = config
|
||||
, ircBotResumeData = M.singleton "HANDLE" (show fd) }
|
||||
ircBotState' <- execStateT (initBotServerConnection config) ircBotState
|
||||
putStrLn "[IrcBot] Spawning plugins..."
|
||||
ircBotState'' <- execStateT spawnIrcPlugins ircBotState'
|
||||
putStrLn "[IrcBot] Entering Core loop... "
|
||||
ircBotState''' <- (execStateT ircBotLoop ircBotState'') `catches` [ Handler (\ (_ :: IOException) -> return (ircBotState''))
|
||||
, Handler (\ (_ :: AsyncException) -> return (ircBotState'')) ]
|
||||
putStrLn "[IrcBot] Killing reader threads..."
|
||||
killThread readerThreadId
|
||||
killThread masterReaderThreadId
|
||||
putStrLn "[IrcBot] Killing active plugins... "
|
||||
let resumeData' = ircBotResumeData ircBotState'''
|
||||
ircPlugins = read (fromMaybe [] (M.lookup "PLUGINS" resumeData')) :: [String]
|
||||
evalStateT (mapM_ killIrcPlugin ircPlugins) ircBotState'''
|
||||
return ()
|
||||
|
||||
--resumeIrcBot
|
||||
--resumeIrcBot
|
||||
|
||||
-- | Runs the IrcBot's reader loop
|
||||
ircBotReader :: Handle -> Chan IrcBotMsg -> ThreadId -> IO ()
|
||||
ircBotReader handle chan fatherThreadId = forever $ do
|
||||
str <- (hGetLine handle) `catch` handleIOException
|
||||
let msg = parseIrcMsg str
|
||||
case msg of
|
||||
Right msg' -> writeChan chan (InIrcMsg msg')
|
||||
_ -> return ()
|
||||
where
|
||||
handleIOException :: IOException -> IO (String)
|
||||
handleIOException ioException = do
|
||||
throwTo fatherThreadId ioException
|
||||
myId <- myThreadId
|
||||
killThread myId
|
||||
return ""
|
||||
|
||||
-- | Reads the Master's chan
|
||||
ircBotMasterReader :: Chan BotMsg -> Chan IrcBotMsg -> IO ()
|
||||
ircBotMasterReader masterChan _ = forever $ do
|
||||
_ <- readChan masterChan
|
||||
return ()
|
||||
-- TODO : handle botMsg
|
||||
|
||||
-- | Initialize the bot's server connection
|
||||
initBotServerConnection :: IrcConfig -> IrcBot ()
|
||||
initBotServerConnection config = do
|
||||
ircBot <- get
|
||||
let ircServerState = ircBotServerState ircBot
|
||||
ircServerState' <- execStateT (initServerConnection config) ircServerState
|
||||
put $ ircBot { ircBotServerState = ircServerState' }
|
||||
|
||||
-- | Run the IrcBot's main loop
|
||||
ircBotLoop :: IrcBot ()
|
||||
ircBotLoop = forever $ do
|
||||
chan <- gets ircBotChan
|
||||
msg <- liftIO $ readChan chan
|
||||
case msg of
|
||||
InIrcMsg inIrcMsg -> dispatchMessage $ InIrcMsg inIrcMsg
|
||||
OutIrcMsg outIrcMsg -> sendThisMessage outIrcMsg
|
||||
IntIrcCmd intIrcCmd -> do
|
||||
reboot <- processInternalCommand $ IntIrcCmd intIrcCmd
|
||||
reportUpdate
|
||||
if reboot == BotReboot
|
||||
then processRebootCommand
|
||||
else return ()
|
||||
where
|
||||
sendThisMessage :: IrcMsg -> IrcBot ()
|
||||
sendThisMessage outputMsg = do
|
||||
let str = serializeIrcMsg outputMsg
|
||||
handle <- gets ircBotHandle
|
||||
liftIO $ hPutStr handle (str ++ "\r\n")
|
||||
|
||||
-- | Dispatches an input message
|
||||
dispatchMessage :: IrcBotMsg -> IrcBot ()
|
||||
dispatchMessage (InIrcMsg inIrcMsg) = do
|
||||
config <- gets ircBotConfig
|
||||
plugins <- gets ircBotPlugins
|
||||
cmds <- gets ircBotCommands
|
||||
if (isPluginCommand config)
|
||||
then
|
||||
let key = tail . head $ words getMsgContent
|
||||
pluginNames = fromMaybe [] $ M.lookup key cmds
|
||||
plugins' = fromMaybe [] $ mapM (flip M.lookup plugins) pluginNames
|
||||
in mapM_ (sendRunCommand (tail getMsgContent) . first) plugins'
|
||||
else
|
||||
mapM_ (sendToPlugin (InIrcMsg inIrcMsg) . first) (M.elems plugins)
|
||||
where
|
||||
isPluginCommand :: IrcConfig -> Bool
|
||||
isPluginCommand config =
|
||||
and [ ircMsgCommand inIrcMsg == "PRIVMSG"
|
||||
, (head getMsgContent) == ircConfigCommandPrefix config ]
|
||||
sendRunCommand :: String -> IrcPluginState -> IrcBot ()
|
||||
sendRunCommand cmd plugin = sendToPlugin (IntIrcCmd $ IrcCmd "RUN" "CORE" (ircPluginName plugin) cmd inIrcMsg) plugin
|
||||
getMsgContent :: String
|
||||
getMsgContent = unwords . tail $ ircMsgParameters inIrcMsg
|
||||
dispatchMessage _ = return ()
|
||||
|
||||
-- | Reports an update to the master bot
|
||||
reportUpdate :: IrcBot ()
|
||||
reportUpdate = do
|
||||
ircbot <- get
|
||||
let masterChan = ircBotMasterChan ircbot
|
||||
msg = UpdMsg $ ResMsg { resMsgFrom = ircConfigName $ ircBotConfig ircbot
|
||||
, resMsgData = ircBotResumeData ircbot }
|
||||
liftIO $ writeChan masterChan msg
|
||||
|
||||
-- | Process a reboot command
|
||||
processRebootCommand :: IrcBot ()
|
||||
processRebootCommand = do
|
||||
ircbot <- get
|
||||
let masterChan = ircBotMasterChan ircbot
|
||||
msg = IntMsg $ Msg { msgType = "REBOOT"
|
||||
, msgFrom = ircConfigName $ ircBotConfig ircbot
|
||||
, msgTo = "CORE"
|
||||
, msgStuff = show $ ircBotResumeData ircbot
|
||||
}
|
||||
liftIO $ writeChan masterChan msg
|
||||
|
||||
|
|
@ -1,73 +0,0 @@
|
|||
module Hsbot.Irc.Message
|
||||
( IrcBotMsg (..)
|
||||
, IrcCmd (..)
|
||||
, IrcMsg (..)
|
||||
, emptyIrcMsg
|
||||
, parseIrcMsg
|
||||
, serializeIrcMsg
|
||||
) where
|
||||
|
||||
import Control.Monad.Identity
|
||||
import Text.Parsec
|
||||
|
||||
-- | An IRC message
|
||||
data IrcMsg = IrcMsg
|
||||
{ ircMsgPrefix :: Maybe String -- the message prefix
|
||||
, ircMsgCommand :: String -- the message command
|
||||
, ircMsgParameters :: [String] -- the message parameters
|
||||
} deriving (Show)
|
||||
|
||||
emptyIrcMsg :: IrcMsg
|
||||
emptyIrcMsg = IrcMsg Nothing "" []
|
||||
|
||||
-- | An internal command
|
||||
data IrcCmd = IrcCmd
|
||||
{ ircCmdCmd :: String -- the internal command
|
||||
, ircCmdFrom :: String -- who issues it
|
||||
, ircCmdTo :: String -- who it is destinated to
|
||||
, ircCmdMsg :: String -- the message to be transfered
|
||||
, ircCmdBotMsg :: IrcMsg -- An IrcMsg attached to the command
|
||||
} deriving (Show)
|
||||
|
||||
data IrcBotMsg = InIrcMsg IrcMsg | OutIrcMsg IrcMsg | IntIrcCmd IrcCmd deriving (Show)
|
||||
|
||||
-- | Parses an IrcInput
|
||||
parseIrcMsg :: String -> Either ParseError IrcMsg
|
||||
parseIrcMsg line = parse pMsg "" line
|
||||
|
||||
pMsg :: ParsecT String u Identity IrcMsg
|
||||
pMsg = do
|
||||
pfx <- optionMaybe pPrefix
|
||||
cmd <- pCommand
|
||||
params <- many (char ' ' >> (pLongParam <|> pShortParam))
|
||||
_ <- char '\r'
|
||||
--eof
|
||||
return $ IrcMsg pfx cmd params
|
||||
|
||||
pPrefix :: ParsecT String u Identity [Char]
|
||||
pPrefix = do
|
||||
_ <- char ':'
|
||||
pfx <- many1 (noneOf " ")
|
||||
_ <- space
|
||||
return pfx
|
||||
|
||||
pCommand :: ParsecT String u Identity [Char]
|
||||
pCommand = count 3 digit <|> many1 upper
|
||||
|
||||
pLongParam :: ParsecT String u Identity [Char]
|
||||
pLongParam = char ':' >> (many1 (noneOf "\r"))
|
||||
|
||||
pShortParam :: ParsecT String u Identity [Char]
|
||||
pShortParam = many1 (noneOf " \r")
|
||||
|
||||
-- | Serialize an IRC message to a string.
|
||||
serializeIrcMsg :: IrcMsg -> String
|
||||
serializeIrcMsg (IrcMsg pfx cmd params) = pfxStr ++ cmd ++ paramStr
|
||||
where pfxStr = case pfx of
|
||||
Nothing -> ""
|
||||
Just pfx' -> ":" ++ pfx' ++ " "
|
||||
paramStr = concat (map paramToStr (init params)
|
||||
++ [lastParamToStr (last params)])
|
||||
paramToStr p = " " ++ p
|
||||
lastParamToStr p = " :" ++ p
|
||||
|
||||
|
|
@ -1,97 +0,0 @@
|
|||
module Hsbot.Irc.Plugin
|
||||
( IrcPlugin
|
||||
, IrcPluginState (..)
|
||||
, killIrcPlugin
|
||||
, listPlugins
|
||||
, loadIrcPlugin
|
||||
, sendToPlugin
|
||||
, spawnIrcPlugins
|
||||
, unloadIrcPlugin
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.Chan ()
|
||||
import Control.Exception
|
||||
import Control.Monad.State
|
||||
import qualified Data.Map as M
|
||||
|
||||
import Hsbot.Irc.Config
|
||||
import Hsbot.Irc.Message
|
||||
import Hsbot.Irc.Plugin.Core
|
||||
import Hsbot.Irc.Plugin.Dummy
|
||||
import Hsbot.Irc.Plugin.Ping
|
||||
import Hsbot.Irc.Plugin.Quote
|
||||
import Hsbot.Irc.Plugin.Utils
|
||||
import Hsbot.Irc.Types
|
||||
|
||||
-- | Sends a msg to a plugin
|
||||
sendToPlugin :: IrcBotMsg -> IrcPluginState -> IrcBot ()
|
||||
sendToPlugin ircBotMsg plugin = do
|
||||
liftIO $ writeChan (ircPluginChan plugin) ircBotMsg
|
||||
|
||||
-- | spawns IrcPlugins
|
||||
spawnIrcPlugins :: IrcBot ()
|
||||
spawnIrcPlugins = do
|
||||
config <- gets ircBotConfig
|
||||
mapM_ (loadIrcPlugin) (ircConfigPlugins config)
|
||||
|
||||
-- | loads an ircbot plugin
|
||||
loadIrcPlugin :: String -> IrcBot ()
|
||||
loadIrcPlugin pluginName = do
|
||||
ircbot <- get
|
||||
let masterChan = ircBotChan ircbot
|
||||
pluginChan <- liftIO (newChan :: IO (Chan IrcBotMsg))
|
||||
let entryPoint = case pluginName of
|
||||
"Core" -> ircBotPluginCore
|
||||
"Ping" -> ircBotPluginPing
|
||||
"Quote" -> ircBotPluginQuote
|
||||
_ -> ircBotPluginDummy
|
||||
let oldPlugins = ircBotPlugins ircbot
|
||||
oldResumeData = ircBotResumeData ircbot
|
||||
-- We check for unicity
|
||||
case M.lookup pluginName oldPlugins of
|
||||
Just _ -> return ()
|
||||
Nothing -> do
|
||||
mvar <- liftIO newEmptyMVar
|
||||
threadId <- liftIO . forkIO $ finally (entryPoint pluginChan masterChan) (putMVar mvar ())
|
||||
let plugin = IrcPluginState { ircPluginName = pluginName
|
||||
, ircPluginChan = pluginChan
|
||||
, ircPluginMasterChan = masterChan }
|
||||
newPlugins = M.insert pluginName (plugin, mvar, threadId) oldPlugins
|
||||
newResumeData = M.insert "PLUGINS" (show $ M.keys newPlugins) oldResumeData
|
||||
put $ ircbot { ircBotPlugins = newPlugins
|
||||
, ircBotResumeData = newResumeData }
|
||||
|
||||
-- | Sends a list of loaded plugins
|
||||
listPlugins :: IrcMsg -> String -> IrcBot ()
|
||||
listPlugins originalRequest dest = do
|
||||
plugins <- gets ircBotPlugins
|
||||
let listing = unwords $ M.keys plugins
|
||||
case M.lookup dest plugins of
|
||||
Just (plugin, _, _) -> sendToPlugin (IntIrcCmd $ IrcCmd "ANSWER" "CORE" dest listing originalRequest) plugin
|
||||
Nothing -> return ()
|
||||
|
||||
-- | Unloads a plugin
|
||||
unloadIrcPlugin :: String -> IrcBot ()
|
||||
unloadIrcPlugin name = do
|
||||
killIrcPlugin name
|
||||
ircbot <- get
|
||||
let oldResumeData = ircBotResumeData ircbot
|
||||
newPlugins = M.keys $ ircBotPlugins ircbot
|
||||
newResumeData = M.insert "PLUGINS" (show newPlugins) oldResumeData
|
||||
put $ ircbot { ircBotResumeData = newResumeData }
|
||||
|
||||
-- | kills a plugin
|
||||
killIrcPlugin :: String -> IrcBot ()
|
||||
killIrcPlugin name = do
|
||||
ircbot <- get
|
||||
let oldPlugins = ircBotPlugins ircbot
|
||||
-- We check if the plugin exists
|
||||
case M.lookup name oldPlugins of
|
||||
Just (_, mvar, threadId) -> do
|
||||
let newPlugins = M.delete name oldPlugins
|
||||
liftIO $ throwTo threadId UserInterrupt
|
||||
put $ ircbot { ircBotPlugins = newPlugins }
|
||||
liftIO $ takeMVar mvar
|
||||
Nothing -> return ()
|
||||
|
||||
|
|
@ -1,66 +0,0 @@
|
|||
module Hsbot.Irc.Plugin.Core
|
||||
( ircBotPluginCore
|
||||
) where
|
||||
|
||||
import Control.Concurrent (Chan)
|
||||
import Control.Exception
|
||||
import Control.Monad.State
|
||||
import Prelude hiding (catch)
|
||||
|
||||
import Hsbot.Irc.Message
|
||||
import Hsbot.Irc.Plugin.Utils
|
||||
|
||||
-- | The plugin's main entry point
|
||||
ircBotPluginCore :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
|
||||
ircBotPluginCore myChan masterChan = do
|
||||
let plugin = IrcPluginState { ircPluginName = "Core"
|
||||
, ircPluginChan = myChan
|
||||
, ircPluginMasterChan = masterChan }
|
||||
evalStateT (mapM_ sendRegisterCommand ["list", "load", "reload", "unload", "reboot"]) plugin
|
||||
plugin' <- (execStateT run plugin) `catch` (\(_ :: AsyncException) -> return plugin)
|
||||
evalStateT (mapM_ sendUnregisterCommand ["list", "load", "reload", "unload", "reboot"]) plugin'
|
||||
|
||||
-- | The IrcPlugin monad main function
|
||||
run :: IrcPlugin ()
|
||||
run = forever $ do
|
||||
msg <- readMsg
|
||||
eval msg
|
||||
where
|
||||
eval :: IrcBotMsg -> IrcPlugin ()
|
||||
eval (IntIrcCmd intCmd) = do
|
||||
let request = ircCmdBotMsg intCmd
|
||||
case ircCmdCmd intCmd of
|
||||
"RUN" -> let stuff = words $ ircCmdMsg intCmd
|
||||
in case head stuff of
|
||||
"list" -> listPlugins request
|
||||
"load" -> loadPlugin $ tail stuff
|
||||
"reload" -> reloadPlugin $ tail stuff
|
||||
"unload" -> unloadPlugin $ tail stuff
|
||||
"reboot" -> rebootBot $ tail stuff
|
||||
_ -> return () -- TODO : help message
|
||||
"ANSWER" -> let stuff = ircCmdMsg intCmd
|
||||
in answerMsg request ("Loaded plugins : " ++ stuff)
|
||||
_ -> return ()
|
||||
eval _ = return ()
|
||||
|
||||
-- | The list command
|
||||
listPlugins :: IrcMsg -> IrcPlugin ()
|
||||
listPlugins request = do
|
||||
sendCommandWithRequest "LIST" "CORE" (unwords []) request
|
||||
|
||||
-- | The load command
|
||||
loadPlugin :: [String] -> IrcPlugin ()
|
||||
loadPlugin pluginNames = mapM_ (sendCommand "LOAD" "CORE") pluginNames
|
||||
|
||||
-- | The reload command
|
||||
reloadPlugin :: [String] -> IrcPlugin ()
|
||||
reloadPlugin pluginNames = mapM_ (sendCommand "RELOAD" "CORE") pluginNames
|
||||
|
||||
-- | The unload command
|
||||
unloadPlugin :: [String] -> IrcPlugin ()
|
||||
unloadPlugin pluginNames = mapM_ (sendCommand "UNLOAD" "CORE") pluginNames
|
||||
|
||||
-- | The reboot command
|
||||
rebootBot :: [String] -> IrcPlugin ()
|
||||
rebootBot stuff = sendCommand "REBOOT" "CORE" $ unwords stuff
|
||||
|
||||
|
|
@ -1,27 +0,0 @@
|
|||
module Hsbot.Irc.Plugin.Dummy
|
||||
( ircBotPluginDummy
|
||||
) where
|
||||
|
||||
import Control.Concurrent.Chan
|
||||
import Control.Exception
|
||||
import Control.Monad.State
|
||||
import Prelude hiding (catch)
|
||||
|
||||
import Hsbot.Irc.Message
|
||||
import Hsbot.Irc.Plugin.Utils
|
||||
|
||||
-- | The plugin's main entry point
|
||||
ircBotPluginDummy :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
|
||||
ircBotPluginDummy myChan masterChan = do
|
||||
let plugin = IrcPluginState { ircPluginName = "Dummy"
|
||||
, ircPluginChan = myChan
|
||||
, ircPluginMasterChan = masterChan }
|
||||
_ <- (execStateT run plugin) `catch` (\(_ :: AsyncException) -> return plugin)
|
||||
return ()
|
||||
|
||||
-- | The IrcPlugin monad main function
|
||||
run :: IrcPlugin ()
|
||||
run = forever $ do
|
||||
_ <- readMsg
|
||||
return ()
|
||||
|
||||
|
|
@ -1,33 +0,0 @@
|
|||
module Hsbot.Irc.Plugin.Ping
|
||||
( ircBotPluginPing
|
||||
) where
|
||||
|
||||
import Control.Concurrent.Chan
|
||||
import Control.Exception
|
||||
import Control.Monad.State
|
||||
import Prelude hiding (catch)
|
||||
|
||||
import Hsbot.Irc.Message
|
||||
import Hsbot.Irc.Plugin.Utils
|
||||
|
||||
-- | The plugin's main entry point
|
||||
ircBotPluginPing :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
|
||||
ircBotPluginPing myChan masterChan = do
|
||||
let plugin = IrcPluginState { ircPluginName = "Ping"
|
||||
, ircPluginChan = myChan
|
||||
, ircPluginMasterChan = masterChan }
|
||||
_ <- (execStateT run plugin) `catch` (\(_ :: AsyncException) -> return plugin)
|
||||
return ()
|
||||
|
||||
-- | The IrcPlugin monad main function
|
||||
run :: IrcPlugin ()
|
||||
run = forever $ do
|
||||
msg <- readMsg
|
||||
eval msg
|
||||
where
|
||||
eval :: IrcBotMsg -> IrcPlugin ()
|
||||
eval (InIrcMsg msg)
|
||||
| (ircMsgCommand msg) == "PING" = writeMsg . OutIrcMsg $ IrcMsg Nothing "PONG" (ircMsgParameters msg)
|
||||
| otherwise = return ()
|
||||
eval _ = return ()
|
||||
|
||||
|
|
@ -1,174 +0,0 @@
|
|||
module Hsbot.Irc.Plugin.Quote
|
||||
( ircBotPluginQuote
|
||||
) where
|
||||
|
||||
import Control.Concurrent.Chan
|
||||
import Control.Exception
|
||||
import Control.Monad.State
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe(fromMaybe)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as TIO
|
||||
import Data.Time
|
||||
import System.Directory
|
||||
import IO hiding (catch)
|
||||
import Prelude hiding (catch)
|
||||
import System.FilePath
|
||||
import System.Posix.Files
|
||||
import System.Random(randomRIO)
|
||||
|
||||
import Hsbot.Irc.Message
|
||||
import Hsbot.Irc.Plugin.Utils
|
||||
|
||||
-- | A quote element
|
||||
data QuoteElt = QuoteElt
|
||||
{ eltQuoter :: String
|
||||
, eltQuote :: String
|
||||
} deriving (Read, Show)
|
||||
|
||||
-- | A quote object
|
||||
data Quote = Quote
|
||||
{ quoter :: String
|
||||
, quote :: [QuoteElt]
|
||||
, quoteTime :: UTCTime
|
||||
, votes :: Int
|
||||
} deriving (Read, Show)
|
||||
|
||||
-- | A QuoteBot state
|
||||
data QuoteBotState = QuoteBotState
|
||||
{ nextQuoteId :: Integer
|
||||
, quoteBotDB :: M.Map Integer Quote
|
||||
, quotesInProgress :: M.Map Integer Quote
|
||||
} deriving (Read, Show)
|
||||
|
||||
-- | The QuoteBot monad
|
||||
type QuoteBot a = StateT QuoteBotState (StateT IrcPluginState IO) a
|
||||
|
||||
-- | The plugin's main entry point
|
||||
ircBotPluginQuote :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
|
||||
ircBotPluginQuote myChan masterChan = do
|
||||
-- First of all we restore the database
|
||||
dir <- getAppUserDataDirectory "hsbot"
|
||||
let dbfile = dir </> "quotedb.txt"
|
||||
dbfileExists <- fileExist dbfile
|
||||
if not dbfileExists
|
||||
then
|
||||
let quoteBot = QuoteBotState 0 M.empty M.empty
|
||||
in TIO.writeFile dbfile (T.pack $ show quoteBot)
|
||||
else
|
||||
return ()
|
||||
txtQuoteBot <- TIO.readFile $ dbfile
|
||||
let quoteBot = read (T.unpack txtQuoteBot) :: QuoteBotState
|
||||
-- The plugin main loop
|
||||
let plugin = IrcPluginState { ircPluginName = "Quote"
|
||||
, ircPluginChan = myChan
|
||||
, ircPluginMasterChan = masterChan }
|
||||
evalStateT (mapM_ sendRegisterCommand ["quote"]) plugin
|
||||
_ <- (evalStateT (run quoteBot) plugin) `catch` (\(_ :: AsyncException) -> return quoteBot)
|
||||
evalStateT (mapM_ sendUnregisterCommand ["quote"]) plugin
|
||||
|
||||
-- | The IrcPlugin monad main function
|
||||
run :: QuoteBotState -> IrcPlugin (QuoteBotState)
|
||||
run quoteBot = do
|
||||
msg <- readMsg
|
||||
quoteBot' <- eval msg
|
||||
run quoteBot'
|
||||
where
|
||||
-- | evaluate what we just received
|
||||
eval :: IrcBotMsg -> IrcPlugin (QuoteBotState)
|
||||
eval (IntIrcCmd intCmd)
|
||||
| ircCmdCmd intCmd == "RUN" = do
|
||||
quoteBot' <- execStateT (runCommand intCmd) quoteBot
|
||||
return quoteBot'
|
||||
| otherwise = return quoteBot
|
||||
eval (InIrcMsg _) = return (quoteBot)
|
||||
eval (OutIrcMsg _) = return (quoteBot)
|
||||
|
||||
-- | run a command we received
|
||||
runCommand :: IrcCmd -> QuoteBot ()
|
||||
runCommand intCmd
|
||||
| theCommand == "quote" = runQuoteCommand
|
||||
| otherwise = return ()
|
||||
where
|
||||
-- | the message is a quote command
|
||||
runQuoteCommand :: QuoteBot ()
|
||||
| length args == 0 = do
|
||||
quoteDB <- gets quoteBotDB
|
||||
x <- liftIO $ randomRIO (0, (length $ M.keys quoteDB) - 1)
|
||||
if (length $ M.keys quoteDB) > 0
|
||||
then
|
||||
mapM_ (lift . answerMsg request) (formatQuote (M.keys quoteDB !! x) (M.elems quoteDB !! x))
|
||||
else
|
||||
lift $ answerMsg request "The quote database is empty."
|
||||
| otherwise = do
|
||||
dispatchQuoteCmd $ head args
|
||||
-- | quote command dispatcher
|
||||
dispatchQuoteCmd :: String -> QuoteBot ()
|
||||
dispatchQuoteCmd cmd
|
||||
| cmd == "start" = do
|
||||
quoteBot <- get
|
||||
now <- liftIO $ getCurrentTime
|
||||
let sender = takeWhile (/= '!') $ fromMaybe "ARGH" (ircMsgPrefix request)
|
||||
newQuote = Quote sender [(quoteElt stuff)] now 0
|
||||
quoteId = nextQuoteId quoteBot
|
||||
quotesInProgress' = M.insert quoteId newQuote (quotesInProgress quoteBot)
|
||||
put $ quoteBot { nextQuoteId = quoteId + 1, quotesInProgress = quotesInProgress' }
|
||||
lift $ answerMsg request ("New quoteId : " ++ show quoteId)
|
||||
syncQuoteBot
|
||||
| cmd == "append" = do
|
||||
quoteBot <- get
|
||||
case reads (head stuff) of
|
||||
[(quoteId :: Integer,"")] -> do
|
||||
case M.lookup quoteId (quotesInProgress quoteBot) of
|
||||
Just theQuote -> do
|
||||
let newQuote = theQuote { quote = (quoteElt $ tail stuff) : (quote theQuote) }
|
||||
quotesInProgress' = M.insert quoteId newQuote (quotesInProgress quoteBot)
|
||||
put $ quoteBot { quotesInProgress = quotesInProgress' }
|
||||
syncQuoteBot
|
||||
Nothing -> lift $ answerMsg request ("quoteId not found : " ++ (show quoteId))
|
||||
_ -> lift $ answerMsg request ("Invalid quoteId : " ++ (head stuff))
|
||||
| cmd == "commit" = do
|
||||
quoteBot <- get
|
||||
case reads (head stuff) of
|
||||
[(quoteId :: Integer,"")] -> do
|
||||
case M.lookup quoteId (quotesInProgress quoteBot) of
|
||||
Just theQuote -> do
|
||||
let quoteBotDB' = M.insert quoteId theQuote (quoteBotDB quoteBot)
|
||||
quotesInProgress' = M.delete quoteId (quotesInProgress quoteBot)
|
||||
put $ quoteBot { quoteBotDB = quoteBotDB', quotesInProgress = quotesInProgress' }
|
||||
syncQuoteBot
|
||||
Nothing -> lift $ answerMsg request ("quoteId not found : " ++ (show quoteId))
|
||||
_ -> lift $ answerMsg request ("Invalid quoteId : " ++ (head stuff))
|
||||
-- | cmd == "abort" =
|
||||
| otherwise = lift $ answerMsg request ("Invalid command : " ++ cmd)
|
||||
-- | Gets the new QuoteElt
|
||||
quoteElt :: [String] -> QuoteElt
|
||||
quoteElt msg = do
|
||||
let budy = head $ msg
|
||||
theQuote = unwords . tail $ msg
|
||||
QuoteElt budy theQuote
|
||||
-- | utilities
|
||||
params = words . ircCmdMsg $ intCmd
|
||||
theCommand = head params
|
||||
args = tail params
|
||||
stuff = tail args
|
||||
request = ircCmdBotMsg intCmd
|
||||
|
||||
-- | The function that sync the quoteDB on disk
|
||||
syncQuoteBot :: QuoteBot ()
|
||||
syncQuoteBot = do
|
||||
dir <- liftIO $ getAppUserDataDirectory "hsbot"
|
||||
let dbfile = dir </> "quotedb.txt"
|
||||
file' <- liftIO $ openFile dbfile WriteMode
|
||||
quoteBot <- get
|
||||
liftIO . hPutStr file' $ show quoteBot
|
||||
liftIO $ hClose file'
|
||||
|
||||
formatQuote :: Integer -> Quote -> [String]
|
||||
formatQuote quoteId theQuote =
|
||||
("+---| " ++ (show quoteId) ++ " |-- Reported by " ++ (quoter theQuote) ++ " on " ++ (show $ quoteTime theQuote)) :
|
||||
foldl (\acc x -> formatQuoteElt x : acc) ["`------------------------------------------"] (quote theQuote)
|
||||
where
|
||||
formatQuoteElt :: QuoteElt -> String
|
||||
formatQuoteElt quoteElt = "| <" ++ (eltQuoter quoteElt) ++ "> " ++ (eltQuote quoteElt)
|
||||
|
||||
|
|
@ -1,66 +0,0 @@
|
|||
module Hsbot.Irc.Plugin.Utils
|
||||
( IrcPlugin
|
||||
, IrcPluginState (..)
|
||||
, answerMsg
|
||||
, readMsg
|
||||
, sendCommand
|
||||
, sendCommandWithRequest
|
||||
, sendRegisterCommand
|
||||
, sendUnregisterCommand
|
||||
, writeMsg
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.Chan ()
|
||||
import Control.Monad.State
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
import Hsbot.Irc.Message
|
||||
|
||||
-- | The IrcPlugin monad
|
||||
type IrcPlugin = StateT IrcPluginState IO
|
||||
|
||||
-- | A plugin state
|
||||
data IrcPluginState = IrcPluginState
|
||||
{ ircPluginName :: String -- The plugin's name
|
||||
, ircPluginChan :: Chan IrcBotMsg -- The plugin chan
|
||||
, ircPluginMasterChan :: Chan IrcBotMsg -- The master's chan
|
||||
}
|
||||
|
||||
--- | Basic input output for IrcPlugins
|
||||
readMsg :: IrcPlugin (IrcBotMsg)
|
||||
readMsg = do
|
||||
chan <- gets ircPluginChan
|
||||
input <- liftIO $ readChan chan
|
||||
return input
|
||||
|
||||
writeMsg :: IrcBotMsg -> IrcPlugin ()
|
||||
writeMsg (OutIrcMsg msg) = do
|
||||
chan <- gets ircPluginMasterChan
|
||||
liftIO $ writeChan chan (OutIrcMsg msg)
|
||||
writeMsg _ = return ()
|
||||
|
||||
answerMsg :: IrcMsg -> String -> IrcPlugin ()
|
||||
answerMsg request msg = do
|
||||
let chanOrigin = head $ ircMsgParameters request
|
||||
sender = takeWhile (/= '!') $ fromMaybe "" (ircMsgPrefix request)
|
||||
case head chanOrigin of
|
||||
'#' -> writeMsg . OutIrcMsg $ IrcMsg Nothing "PRIVMSG" [chanOrigin, msg]
|
||||
_ -> writeMsg . OutIrcMsg $ IrcMsg Nothing "PRIVMSG" [sender, msg]
|
||||
|
||||
-- | Command management
|
||||
sendCommand :: String -> String -> String -> IrcPlugin ()
|
||||
sendCommand cmd to params = sendCommandWithRequest cmd to params emptyIrcMsg
|
||||
|
||||
sendCommandWithRequest :: String -> String -> String -> IrcMsg -> IrcPlugin ()
|
||||
sendCommandWithRequest cmd to params originalRequest = do
|
||||
masterChan <- gets ircPluginMasterChan
|
||||
from <- gets ircPluginName
|
||||
liftIO . writeChan masterChan . IntIrcCmd $ IrcCmd cmd from to params originalRequest
|
||||
|
||||
sendRegisterCommand :: String -> IrcPlugin ()
|
||||
sendRegisterCommand cmd = sendCommand "REGISTER" "CORE" cmd
|
||||
|
||||
sendUnregisterCommand :: String -> IrcPlugin ()
|
||||
sendUnregisterCommand cmd = sendCommand "UNREGISTER" "CORE" cmd
|
||||
|
||||
|
|
@ -1,35 +0,0 @@
|
|||
module Hsbot.Irc.Server
|
||||
( initServerConnection
|
||||
, sendIrcMsg
|
||||
) where
|
||||
|
||||
import Control.Concurrent.Chan
|
||||
import Control.Monad.State
|
||||
|
||||
import Hsbot.Irc.Config
|
||||
import Hsbot.Irc.Message
|
||||
import Hsbot.Irc.Types
|
||||
|
||||
-- | Setup a newly connected server by sending nick and join stuff
|
||||
initServerConnection :: IrcConfig -> IrcServer ()
|
||||
initServerConnection config = do
|
||||
sendIrcMsg $ IrcMsg Nothing "NICK" [(ircConfigNickname config)]
|
||||
sendIrcMsg $ IrcMsg Nothing "USER" [(ircConfigNickname config), "0", "*", (ircConfigRealname config)]
|
||||
when (not . null $ ircConfigPassword config) $ do
|
||||
sendIrcMsg $ IrcMsg Nothing "PRIVMSG" ["nickserv", "identify", (ircConfigPassword config)]
|
||||
mapM_ joinChan (ircConfigChannels config)
|
||||
|
||||
-- | Joins a chan
|
||||
joinChan :: String -> IrcServer ()
|
||||
joinChan channel = do
|
||||
ircServer <- get
|
||||
let oldChannels = ircServerChannels ircServer
|
||||
sendIrcMsg $ IrcMsg Nothing "JOIN" [channel]
|
||||
put $ ircServer { ircServerChannels = channel : oldChannels }
|
||||
|
||||
-- | Sends an IrcMsg
|
||||
sendIrcMsg :: IrcMsg -> IrcServer ()
|
||||
sendIrcMsg ircMsg = do
|
||||
chan <- gets ircServerChan
|
||||
liftIO $ writeChan chan (OutIrcMsg ircMsg)
|
||||
|
||||
|
|
@ -1,48 +0,0 @@
|
|||
module Hsbot.Irc.Types
|
||||
( IrcBot
|
||||
, IrcBotState (..)
|
||||
, IrcServer
|
||||
, IrcServerState (..)
|
||||
, first
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Monad.State
|
||||
import qualified Data.Map as M
|
||||
import System.IO
|
||||
|
||||
import Hsbot.Irc.Config
|
||||
import Hsbot.Irc.Message
|
||||
import Hsbot.Irc.Plugin.Utils
|
||||
import Hsbot.Types
|
||||
|
||||
-- | The Ircbot monad
|
||||
type IrcBot = StateT IrcBotState IO
|
||||
|
||||
-- | An Ircbot state
|
||||
data IrcBotState = IrcBotState
|
||||
{ ircBotPlugins :: M.Map String (IrcPluginState, MVar (), ThreadId) -- Loaded plugins
|
||||
, ircBotCommands :: M.Map String [String] -- Loaded plugins
|
||||
, ircBotChan :: Chan IrcBotMsg -- The IrcBot's communication channel
|
||||
, ircBotMasterChan :: Chan BotMsg -- The Hsbot communication channel
|
||||
, ircBotServerState :: IrcServerState -- The state of the IrcServer
|
||||
, ircBotHandle :: Handle -- The server's socket/handle
|
||||
, ircBotConfig :: IrcConfig -- The starting configuration
|
||||
, ircBotResumeData :: ResumeData -- the necessary data to resume the bot's operations on reboot
|
||||
}
|
||||
|
||||
-- | The IrcServer monad
|
||||
type IrcServer = StateT IrcServerState IrcBot
|
||||
|
||||
-- | An IRC server
|
||||
data IrcServerState = IrcServerState
|
||||
{ ircServerId :: String -- the server's address
|
||||
, ircServerChannels :: [String] -- the Channels we are connected to
|
||||
, ircServerNickname :: String -- the hsbot's nickname
|
||||
, ircServerCommandPrefix :: Char -- the prefix the ircbot will recognize as commands
|
||||
, ircServerChan :: Chan IrcBotMsg -- the IrcBot channel
|
||||
}
|
||||
|
||||
-- | Utilities for triplets
|
||||
first :: (a, b, c) -> a
|
||||
first (a, _, _) = a
|
||||
File diff suppressed because it is too large
Load diff
|
|
@ -1,35 +0,0 @@
|
|||
module Hsbot.Message
|
||||
( processInternalMessage
|
||||
, processRebootMessage
|
||||
, processExitMessage
|
||||
) where
|
||||
|
||||
import Control.Monad.State
|
||||
import qualified Data.Map as M
|
||||
|
||||
import Hsbot.PluginUtils
|
||||
import Hsbot.Types
|
||||
|
||||
-- | Processes an internal message
|
||||
processInternalMessage :: Msg -> Bot (BotStatus)
|
||||
processInternalMessage msg
|
||||
| msgTo msg == "CORE" = processCoreMessage msg
|
||||
| otherwise = do
|
||||
plugins <- gets botPlugins
|
||||
case M.lookup (msgTo msg) plugins of
|
||||
Just (plugin, _, _) -> sendToPlugin (IntMsg msg) plugin
|
||||
Nothing -> return ()
|
||||
return BotContinue
|
||||
|
||||
processCoreMessage :: Msg -> Bot (BotStatus)
|
||||
processCoreMessage msg = do
|
||||
case msgType msg of
|
||||
"REBOOT" -> return BotReboot
|
||||
_ -> return BotContinue
|
||||
|
||||
processRebootMessage :: RebootMsg -> Bot (BotStatus)
|
||||
processRebootMessage _ = return BotReboot -- TODO : check who is sending that to us
|
||||
|
||||
processExitMessage :: ExitMsg -> Bot (BotStatus)
|
||||
processExitMessage _ = return BotExit -- TODO : check who is sending that to us
|
||||
|
||||
|
|
@ -1,67 +0,0 @@
|
|||
module Hsbot.Plugin
|
||||
( killPlugin
|
||||
, spawnPlugins
|
||||
, spawnPlugin
|
||||
, unloadPlugin
|
||||
) where
|
||||
|
||||
import Control.Concurrent (forkIO)
|
||||
import Control.Concurrent.Chan
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Exception
|
||||
import Control.Monad.State
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Prelude hiding (catch)
|
||||
|
||||
import Hsbot.Config
|
||||
import Hsbot.Irc.Config
|
||||
import Hsbot.Irc.Core
|
||||
import Hsbot.Types
|
||||
|
||||
-- | spawns plugins
|
||||
spawnPlugins :: Bot ()
|
||||
spawnPlugins = do
|
||||
config <- gets botConfig
|
||||
mapM_ (spawnPlugin) config
|
||||
|
||||
-- | spawns a single plugin
|
||||
spawnPlugin :: BotConfig -> Bot ()
|
||||
spawnPlugin (IrcBotConfig ircConfig) = do
|
||||
bot <- get
|
||||
let mvar = botResumeData bot
|
||||
name = ircConfigName ircConfig
|
||||
resumeData <- liftIO $ takeMVar mvar
|
||||
let pluginResumeData = fromMaybe M.empty $ M.lookup name resumeData
|
||||
chan = botChan bot
|
||||
pchan <- liftIO (newChan :: IO (Chan BotMsg))
|
||||
pluginMVar <- liftIO newEmptyMVar
|
||||
threadId <- liftIO . forkIO $ finally (startIrcbot ircConfig chan pchan (Just $ show pluginResumeData)) (putMVar pluginMVar ())
|
||||
let plugin = PluginState { pluginName = name
|
||||
, pluginChan = pchan
|
||||
, pluginHandles = M.empty }
|
||||
plugins = botPlugins bot
|
||||
put $ bot { botPlugins = M.insert (pluginName plugin) (plugin, pluginMVar, threadId) plugins }
|
||||
liftIO . putMVar mvar $ M.insert name pluginResumeData resumeData
|
||||
|
||||
-- | Unloads a plugin
|
||||
unloadPlugin :: String -> Bot ()
|
||||
unloadPlugin name = do
|
||||
killPlugin name
|
||||
resumeData <- gets botResumeData
|
||||
liftIO $ modifyMVar_ resumeData (\oldData -> return $ M.delete name oldData)
|
||||
|
||||
-- | kills a plugin
|
||||
killPlugin :: String -> Bot ()
|
||||
killPlugin name = do
|
||||
bot <- get
|
||||
let oldPlugins = botPlugins bot
|
||||
-- We check if the plugin exists
|
||||
case M.lookup name oldPlugins of
|
||||
Just (_, mvar, threadId) -> do
|
||||
let newPlugins = M.delete name oldPlugins
|
||||
liftIO $ throwTo threadId UserInterrupt
|
||||
put $ bot { botPlugins = newPlugins }
|
||||
liftIO $ takeMVar mvar
|
||||
Nothing -> return ()
|
||||
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
module Hsbot.PluginUtils
|
||||
( sendToPlugin
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.Chan ()
|
||||
import Control.Monad.State
|
||||
|
||||
import Hsbot.Types
|
||||
|
||||
-- | Sends a msg to a plugin
|
||||
sendToPlugin :: BotMsg -> PluginState -> Bot ()
|
||||
sendToPlugin botMsg plugin = do
|
||||
liftIO $ writeChan (pluginChan plugin) botMsg
|
||||
|
||||
|
|
@ -1,75 +0,0 @@
|
|||
module Hsbot.Types
|
||||
( Bot
|
||||
, BotMsg (..)
|
||||
, BotResumeData
|
||||
, BotState (..)
|
||||
, BotStatus (..)
|
||||
, ExitMsg (..)
|
||||
, Msg (..)
|
||||
, Plugin
|
||||
, PluginState (..)
|
||||
, RebootMsg (..)
|
||||
, ResumeData
|
||||
, ResumeMsg (..)
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Monad.State
|
||||
import qualified Data.Map as M
|
||||
import Data.Time
|
||||
import System.IO
|
||||
|
||||
import Hsbot.Config
|
||||
|
||||
-- | The Bot monad
|
||||
type Bot = StateT BotState IO
|
||||
|
||||
-- | An Hsbot state
|
||||
data BotState = BotState
|
||||
{ botStartTime :: UTCTime -- the bot's uptime
|
||||
, botPlugins :: M.Map String (PluginState, MVar (), ThreadId) -- Loaded plugins
|
||||
, botChan :: Chan BotMsg -- the bot's communication channel
|
||||
, botConfig :: [BotConfig] -- the bot's starting config
|
||||
, botResumeData :: MVar BotResumeData -- the necessary data to resume the bot's operations on reboot
|
||||
}
|
||||
|
||||
-- | how we exit from the botLoop
|
||||
data BotStatus = BotExit | BotReboot | BotContinue deriving (Eq)
|
||||
|
||||
-- | Types to factorise resume data
|
||||
type ResumeData = M.Map String String
|
||||
type BotResumeData = M.Map String ResumeData
|
||||
|
||||
-- | The Plugin monad
|
||||
type Plugin = StateT PluginState IO
|
||||
|
||||
-- | A plugin state
|
||||
data PluginState = PluginState
|
||||
{ pluginName :: String -- The plugin's name
|
||||
, pluginChan :: Chan BotMsg -- The plugin chan
|
||||
, pluginHandles :: M.Map String Handle -- the plugins's handles
|
||||
}
|
||||
|
||||
-- | A hsbot message
|
||||
data Msg = Msg
|
||||
{ msgType :: String -- the message type
|
||||
, msgFrom :: String -- who issues it
|
||||
, msgTo :: String -- who it is destinated to
|
||||
, msgStuff :: String -- the message to be transfered
|
||||
} deriving (Show)
|
||||
|
||||
data ResumeMsg = ResMsg
|
||||
{ resMsgFrom :: String
|
||||
, resMsgData :: ResumeData
|
||||
} deriving (Show)
|
||||
|
||||
data RebootMsg = RebootMsg
|
||||
{ rebMsgFrom :: String
|
||||
} deriving (Show)
|
||||
|
||||
data ExitMsg = ExitMsg
|
||||
{ exiMsgFrom :: String
|
||||
} deriving (Show)
|
||||
|
||||
data BotMsg = IntMsg Msg | UpdMsg ResumeMsg | RebMsg RebootMsg | ExiMsg ExitMsg deriving (Show)
|
||||
|
||||
Reference in a new issue