Rewrote nearly everything!
* Rewrote the whole architecture to achieve extreme modularity * Added the ability to build a multiprotocol bot * Added cabal integration * Added configuration handling the XMonad style * Added configuration in ~/.hsbot * Refactored many many named and functions * Refactored data structures * Cleaned a big bunch of stuff
This commit is contained in:
Julien Dessaux
parent
c20cfe88b3
commit
c1662ba7b9
33 changed files with 856 additions and 654 deletions
32
Config.hs
32
Config.hs
|
|
@ -1,32 +0,0 @@
|
|||
module Config
|
||||
( config
|
||||
, defaultPlugins
|
||||
) where
|
||||
|
||||
import Network
|
||||
|
||||
import Hsbot.Types
|
||||
|
||||
-- | Imported plugins goes there
|
||||
defaultPlugins :: [String]
|
||||
defaultPlugins = []
|
||||
|
||||
-- | User server
|
||||
localhost :: IrcServer
|
||||
localhost = IrcServer
|
||||
{ serverAddress = "localhost"
|
||||
, serverPort = PortNumber 6667
|
||||
, joinChannels = ["#shbot", "#geek"]
|
||||
, nickname = "hsbot"
|
||||
, password = ""
|
||||
, realname = "The One True bot, with it's haskell soul."
|
||||
, administrators = ["julien"]
|
||||
}
|
||||
|
||||
-- | User configuration
|
||||
config :: Config
|
||||
config = Config
|
||||
{ commandPrefix = '@'
|
||||
, ircServer = localhost
|
||||
}
|
||||
|
||||
30
Hsbot.hs
30
Hsbot.hs
|
|
@ -1,30 +0,0 @@
|
|||
module Hsbot
|
||||
( module Config
|
||||
, module Hsbot.Command
|
||||
, module Hsbot.Core
|
||||
, module Hsbot.IRC
|
||||
, module Hsbot.IRCParser
|
||||
, module Hsbot.IRCPlugin
|
||||
, module Hsbot.Main
|
||||
, module Hsbot.Plugin
|
||||
, module Hsbot.Types
|
||||
, module Hsbot.Utils
|
||||
, module Plugins.Core
|
||||
, module Plugins.Ping
|
||||
, module Plugins.Quote
|
||||
) where
|
||||
|
||||
import Config
|
||||
import Hsbot.Command
|
||||
import Hsbot.Core
|
||||
import Hsbot.IRC
|
||||
import Hsbot.IRCParser
|
||||
import Hsbot.IRCPlugin
|
||||
import Hsbot.Main
|
||||
import Hsbot.Plugin
|
||||
import Hsbot.Types
|
||||
import Hsbot.Utils
|
||||
import Plugins.Core
|
||||
import Plugins.Ping
|
||||
import Plugins.Quote
|
||||
|
||||
|
|
@ -1,87 +0,0 @@
|
|||
module Hsbot.Command
|
||||
( dispatchMessage
|
||||
, processInternalCommand
|
||||
, registerCommand
|
||||
, unregisterCommand
|
||||
) where
|
||||
|
||||
import Control.Monad.State
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
|
||||
import Config
|
||||
import Hsbot.Plugin
|
||||
import Hsbot.Types
|
||||
import Hsbot.Utils
|
||||
|
||||
-- | Registers a plugin's command
|
||||
registerCommand :: String -> String -> IrcBot ()
|
||||
registerCommand cmd pluginName' = do
|
||||
bot <- get
|
||||
cmds <- gets botCommands
|
||||
plugins <- gets botPlugins
|
||||
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 $ bot { botCommands = newCmds }
|
||||
Nothing -> traceM $ inColor ("Couldn't register command \"" ++ cmd ++ "\" for plugin \""
|
||||
++ pluginName' ++ "\" : plugin does not exists") [31]
|
||||
|
||||
-- | Unregisters a plugin's command
|
||||
unregisterCommand :: String -> String -> IrcBot ()
|
||||
unregisterCommand cmd pluginName' = do
|
||||
bot <- get
|
||||
cmds <- gets botCommands
|
||||
let newCmds = M.adjust (L.delete pluginName') cmd cmds
|
||||
put $ bot { botCommands = newCmds }
|
||||
|
||||
-- | Dispatches an input message
|
||||
dispatchMessage :: BotMsg -> IrcBot ()
|
||||
dispatchMessage (InputMsg inputMsg)
|
||||
| isPluginCommand = do
|
||||
plugins <- gets botPlugins
|
||||
cmds <- gets botCommands
|
||||
let key = tail . head $ words getMsgContent
|
||||
pluginNames = fromMaybe [] $ M.lookup key cmds
|
||||
plugins' = fromMaybe [] $ mapM (flip M.lookup plugins) pluginNames
|
||||
mapM_ (sendRunCommand $ tail getMsgContent) plugins'
|
||||
| otherwise = do
|
||||
plugins <- gets botPlugins
|
||||
mapM_ (sendToPlugin (InputMsg inputMsg)) (M.elems plugins)
|
||||
where
|
||||
isPluginCommand :: Bool
|
||||
isPluginCommand =
|
||||
and [ command inputMsg == "PRIVMSG"
|
||||
, (head getMsgContent) == (commandPrefix config) ]
|
||||
sendRunCommand :: String -> Plugin -> IrcBot ()
|
||||
sendRunCommand cmd plugin = do
|
||||
sendToPlugin (InternalCmd $ IntCmd "RUN" "CORE" (pluginName plugin) cmd inputMsg) plugin
|
||||
getMsgContent :: String
|
||||
getMsgContent = unwords . tail $ parameters inputMsg
|
||||
dispatchMessage _ = return ()
|
||||
|
||||
-- | Processes an internal command
|
||||
processInternalCommand :: BotMsg -> IrcBot ()
|
||||
processInternalCommand (InternalCmd intCmd) = do
|
||||
plugins <- gets botPlugins
|
||||
if intCmdTo intCmd == "CORE"
|
||||
then processCoreCommand intCmd
|
||||
else case M.lookup (intCmdTo intCmd) plugins of
|
||||
Just plugin -> sendToPlugin (InternalCmd intCmd) plugin
|
||||
Nothing -> errorM $ "Invalid destination in message : " ++ (show intCmd)
|
||||
processInternalCommand _ = return ()
|
||||
|
||||
-- | Processes a core command
|
||||
processCoreCommand :: IntCmd -> IrcBot ()
|
||||
processCoreCommand intCmd = do
|
||||
let command' = intCmdCmd intCmd
|
||||
originalRequest = intCmdBotMsg intCmd
|
||||
case command' of
|
||||
"LIST" -> listPlugins originalRequest (intCmdFrom intCmd)
|
||||
"LOAD" -> traceM $ inColor "hsbot has been compiled in static mode." [31]
|
||||
"UNLOAD" -> unloadPlugin $ intCmdMsg intCmd
|
||||
"REGISTER" -> registerCommand (intCmdMsg intCmd) (intCmdFrom intCmd)
|
||||
"UNREGISTER" -> unregisterCommand (intCmdMsg intCmd) (intCmdFrom intCmd)
|
||||
_ -> traceM $ inColor ("Invalid command : " ++ (show intCmd)) [31]
|
||||
|
||||
18
Hsbot/Config.hs
Normal file
18
Hsbot/Config.hs
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
module Hsbot.Config
|
||||
( Config(..)
|
||||
, defaultConfig
|
||||
) where
|
||||
|
||||
import Hsbot.Irc.Config (IrcConfig)
|
||||
|
||||
-- | Configuration data type
|
||||
data Config = Config
|
||||
{ ircConfigs :: [IrcConfig]
|
||||
}
|
||||
|
||||
-- | User configuration
|
||||
defaultConfig :: Config
|
||||
defaultConfig = Config
|
||||
{ ircConfigs = []
|
||||
}
|
||||
|
||||
112
Hsbot/Core.hs
112
Hsbot/Core.hs
|
|
@ -1,71 +1,69 @@
|
|||
module Hsbot.Core
|
||||
( connectServer
|
||||
, disconnectServer
|
||||
( hsbot
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.Chan ()
|
||||
import Control.Exception(IOException, catch)
|
||||
import Control.Exception
|
||||
import Control.Monad.State
|
||||
import Data.List()
|
||||
import qualified Data.Map as M
|
||||
import Network
|
||||
import Data.Time
|
||||
import Prelude hiding (catch)
|
||||
import System.IO
|
||||
import System.Time (getClockTime)
|
||||
import System.IO()
|
||||
|
||||
import Hsbot.IRCParser
|
||||
import Hsbot.Config
|
||||
import Hsbot.Irc.Config
|
||||
import Hsbot.Irc.Core (ircbot)
|
||||
import Hsbot.Message
|
||||
import Hsbot.Plugin
|
||||
import Hsbot.Types
|
||||
import Hsbot.Utils
|
||||
|
||||
-- Connect to the server and return the initial bot state
|
||||
connectServer :: IrcServer -> IO Bot
|
||||
connectServer server = do
|
||||
let name = serverAddress server
|
||||
starttime <- getClockTime
|
||||
putStr $ "Connecting to " ++ name ++ "... "
|
||||
handle <- connectTo name $ serverPort server
|
||||
hSetBuffering handle NoBuffering
|
||||
putStrLn "done."
|
||||
putStr "Opening server communication channel... "
|
||||
-- | 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 -- Loaded plugins
|
||||
, botChan :: Chan BotMsg -- The bot's communication channel
|
||||
, botConfig :: Config -- the bot's starting config
|
||||
}
|
||||
|
||||
-- | Bot's main entry point
|
||||
hsbot :: Config -> IO ()
|
||||
hsbot config = do
|
||||
startTime <- getCurrentTime
|
||||
putStrLn "[Hsbot] Opening communication channel... "
|
||||
chan <- newChan :: IO (Chan BotMsg)
|
||||
myFatherThreadId <- myThreadId
|
||||
threadId <- forkIO $ botReader handle chan myFatherThreadId
|
||||
putStrLn "done."
|
||||
return $ Bot server starttime handle [] M.empty chan threadId M.empty
|
||||
|
||||
-- | Disconnect from the server
|
||||
disconnectServer :: IrcBot ()
|
||||
disconnectServer = do
|
||||
bot <- get
|
||||
let name = serverAddress $ serverConfig bot
|
||||
liftIO $ putStr "Shutting down plugins..."
|
||||
mapM_ unloadPlugin (M.keys $ botPlugins bot)
|
||||
liftIO $ putStrLn"done."
|
||||
liftIO $ putStr "Closing server communication channel... "
|
||||
liftIO . killThread $ readerThreadId bot
|
||||
liftIO $ putStrLn "done."
|
||||
liftIO . putStr $ "Disconnecting from " ++ name ++ "... "
|
||||
liftIO . hClose $ botHandle bot
|
||||
liftIO $ putStrLn "done."
|
||||
|
||||
-- | Socket reading loop
|
||||
botReader :: Handle -> Chan BotMsg -> ThreadId -> IO ()
|
||||
botReader handle chan fatherThreadId = forever $ do
|
||||
str <- (hGetLine handle) `catch` handleIOException
|
||||
let msg = parseIrcMsg str
|
||||
case msg of
|
||||
Right msg' -> do
|
||||
trace $ inColor ("<-- " ++ (show msg')) [33]
|
||||
writeChan chan (InputMsg msg')
|
||||
_ -> do
|
||||
putStrLn "[Hsbot] Spawning IrcBot plugins... "
|
||||
botState <- execStateT spawnIrcPlugins BotState { botStartTime = startTime
|
||||
, botPlugins = M.empty
|
||||
, botChan = chan
|
||||
, botConfig = config }
|
||||
putStrLn "[Hsbot] Entering main loop... "
|
||||
botState' <- (execStateT botLoop botState) `catch` (\(_ :: IOException) -> return botState)
|
||||
return ()
|
||||
where
|
||||
handleIOException :: IOException -> IO (String)
|
||||
handleIOException ioException = do
|
||||
throwTo fatherThreadId ioException
|
||||
myId <- myThreadId
|
||||
killThread myId
|
||||
return ""
|
||||
|
||||
-- | Run the bot main loop
|
||||
botLoop :: Bot ()
|
||||
botLoop = forever $ do
|
||||
chan <- gets botChan
|
||||
msg <- liftIO $ readChan chan
|
||||
-- process messages
|
||||
return ()
|
||||
|
||||
-- | spawns IrcPlugins
|
||||
spawnIrcPlugins :: Bot ()
|
||||
spawnIrcPlugins = do
|
||||
config <- gets botConfig
|
||||
mapM_ (spawnIrcPlugin) (ircConfigs config)
|
||||
where
|
||||
spawnIrcPlugin :: IrcConfig -> Bot ()
|
||||
spawnIrcPlugin config = do
|
||||
bot <- get
|
||||
let chan = botChan bot
|
||||
pchan <- liftIO (newChan :: IO (Chan BotMsg))
|
||||
threadId <- liftIO $ forkIO (ircbot config chan pchan)
|
||||
let plugin = PluginState (ircConfigName config) threadId pchan M.empty
|
||||
plugins = botPlugins bot
|
||||
put $ bot { botPlugins = M.insert (pluginName plugin) plugin plugins }
|
||||
|
||||
|
|
|
|||
45
Hsbot/IRC.hs
45
Hsbot/IRC.hs
|
|
@ -1,45 +0,0 @@
|
|||
module Hsbot.IRC
|
||||
( initServer
|
||||
, runServer
|
||||
) where
|
||||
|
||||
import Control.Concurrent.Chan
|
||||
import Control.Monad.State
|
||||
|
||||
import Hsbot.Command
|
||||
import Hsbot.IRCParser
|
||||
import Hsbot.Types
|
||||
import Hsbot.Utils
|
||||
|
||||
-- | Setup a newly connected server by sending nick and join stuff
|
||||
initServer :: IrcBot ()
|
||||
initServer = do
|
||||
server <- gets serverConfig
|
||||
sendstr . serializeIrcMsg $ IrcMsg Nothing "NICK" [(nickname server)]
|
||||
sendstr . serializeIrcMsg $ IrcMsg Nothing "USER" [(nickname server), "0", "*", (realname server)]
|
||||
when (not . null $ password server) $ do
|
||||
sendstr . serializeIrcMsg $ IrcMsg Nothing "PRIVMSG" ["nickserv", "identify", (password server)]
|
||||
mapM_ joinChan (joinChannels server)
|
||||
|
||||
-- | Run a server
|
||||
runServer :: IrcBot ()
|
||||
runServer = forever $ do
|
||||
chan <- gets botChannel
|
||||
let input = readChan chan
|
||||
msg <- liftIO input
|
||||
case msg of
|
||||
InputMsg inputMsg -> dispatchMessage $ InputMsg inputMsg
|
||||
OutputMsg outputMsg -> sendstr (serializeIrcMsg outputMsg)
|
||||
InternalCmd internalCmd -> processInternalCommand $ InternalCmd internalCmd
|
||||
|
||||
-- | Joins a chan
|
||||
joinChan :: String -> IrcBot ()
|
||||
joinChan name = do
|
||||
bot <- get
|
||||
let oldChannels = chans bot
|
||||
newChannel = Channel name
|
||||
(nickname $ serverConfig bot)
|
||||
(administrators $ serverConfig bot)
|
||||
sendstr . serializeIrcMsg $ IrcMsg Nothing "JOIN" [name]
|
||||
put $ bot { chans = newChannel : oldChannels }
|
||||
|
||||
|
|
@ -1,66 +0,0 @@
|
|||
module Hsbot.IRCPlugin
|
||||
( IrcPlugin
|
||||
, PluginState(..)
|
||||
, answerMsg
|
||||
, readMsg
|
||||
, sendCommand
|
||||
, sendCommandWithRequest
|
||||
, sendRegisterCommand
|
||||
, sendUnregisterCommand
|
||||
, writeMsg
|
||||
) where
|
||||
|
||||
import Control.Concurrent.Chan
|
||||
import Control.Monad.State
|
||||
import Data.Maybe(fromMaybe)
|
||||
|
||||
import Hsbot.Types
|
||||
|
||||
-- | The IrcPlugin monad
|
||||
type IrcPlugin a = StateT PluginState IO a
|
||||
|
||||
-- | An IRCPlugin state
|
||||
data PluginState = PluginState
|
||||
{ instanceName :: String -- The plugin's name
|
||||
, instanceServerChan :: Chan BotMsg -- The server channel
|
||||
, instanceChan :: Chan BotMsg -- The plugin channel
|
||||
}
|
||||
|
||||
-- | Basic input output for IrcPlugins
|
||||
readMsg :: IrcPlugin (BotMsg)
|
||||
readMsg = do
|
||||
chan <- gets instanceChan
|
||||
input <- liftIO $ readChan chan
|
||||
return input
|
||||
|
||||
writeMsg :: BotMsg -> IrcPlugin ()
|
||||
writeMsg botMsg = do
|
||||
serverChan <- gets instanceServerChan
|
||||
liftIO . writeChan serverChan $ botMsg
|
||||
|
||||
answerMsg :: IrcMsg -> String -> IrcPlugin ()
|
||||
answerMsg request msg = do
|
||||
let chanOrigin = head $ parameters request
|
||||
sender = takeWhile (/= '!') $ fromMaybe "" (prefix request)
|
||||
case head chanOrigin of
|
||||
'#' -> writeMsg . OutputMsg $ IrcMsg Nothing "PRIVMSG" [chanOrigin, msg]
|
||||
_ -> writeMsg . OutputMsg $ IrcMsg Nothing "PRIVMSG" [sender, msg]
|
||||
|
||||
-- | Commands 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
|
||||
serverChan <- gets instanceServerChan
|
||||
from <- gets instanceName
|
||||
liftIO . writeChan serverChan . InternalCmd $ IntCmd cmd from to params originalRequest
|
||||
|
||||
sendRegisterCommand :: String -> IrcPlugin ()
|
||||
sendRegisterCommand cmd = sendCommand "REGISTER" "CORE" cmd
|
||||
|
||||
sendUnregisterCommand :: String -> IrcPlugin ()
|
||||
sendUnregisterCommand cmd = sendCommand "UNREGISTER" "CORE" cmd
|
||||
|
||||
-- | a isAdmin helper : I need an admin plugin (to track admins' status around chans)
|
||||
|
||||
59
Hsbot/Irc/Command.hs
Normal file
59
Hsbot/Irc/Command.hs
Normal file
|
|
@ -0,0 +1,59 @@
|
|||
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
|
||||
|
||||
-- | 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 ()
|
||||
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 ()
|
||||
processInternalCommand _ = return ()
|
||||
|
||||
-- | Processes a core command
|
||||
processCoreCommand :: IrcCmd -> IrcBot ()
|
||||
processCoreCommand ircCmd = do
|
||||
let command' = ircCmdCmd ircCmd
|
||||
originalRequest = ircCmdBotMsg ircCmd
|
||||
case command' of
|
||||
"LIST" -> listPlugins originalRequest (ircCmdFrom ircCmd)
|
||||
"LOAD" -> loadIrcPlugin $ ircCmdMsg ircCmd
|
||||
"UNLOAD" -> unloadPlugin $ ircCmdMsg ircCmd
|
||||
"REGISTER" -> registerCommand (ircCmdMsg ircCmd) (ircCmdFrom ircCmd)
|
||||
"UNREGISTER" -> unregisterCommand (ircCmdMsg ircCmd) (ircCmdFrom ircCmd)
|
||||
_ -> return ()
|
||||
|
||||
34
Hsbot/Irc/Config.hs
Normal file
34
Hsbot/Irc/Config.hs
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
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 = "localhost"
|
||||
, ircConfigAddress = "localhost"
|
||||
, ircConfigPort = PortNumber 6667
|
||||
, ircConfigChannels = ["#hsbot"]
|
||||
, ircConfigNickname = "hsbot"
|
||||
, ircConfigPassword = ""
|
||||
, ircConfigRealname = "The One True bot, with it's haskell soul."
|
||||
, ircConfigCommandPrefix = '@'
|
||||
, ircConfigPlugins = ["Ping"]
|
||||
}
|
||||
|
||||
142
Hsbot/Irc/Core.hs
Normal file
142
Hsbot/Irc/Core.hs
Normal file
|
|
@ -0,0 +1,142 @@
|
|||
module Hsbot.Irc.Core
|
||||
( ircbot
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Exception (IOException, catch)
|
||||
import Control.Monad.State
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Time
|
||||
import Network
|
||||
import Prelude hiding (catch)
|
||||
import System.IO
|
||||
|
||||
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.Message (BotMsg)
|
||||
|
||||
-- | IrcBot's main entry point
|
||||
ircbot :: IrcConfig -> Chan BotMsg -> Chan BotMsg -> IO ()
|
||||
ircbot config masterChan myChan = do
|
||||
startTime <- getCurrentTime
|
||||
putStrLn "[IrcBot] Opening communication channel... "
|
||||
chan <- newChan :: IO (Chan IrcBotMsg)
|
||||
putStrLn $ concat ["[IrcBot] Connecting to ", ircConfigAddress config, "... "]
|
||||
handle <- connectTo (ircConfigAddress config) (ircConfigPort config)
|
||||
hSetBuffering handle NoBuffering
|
||||
myOwnThreadId <- myThreadId
|
||||
putStrLn "[IrcBot] Spawning reader threads..."
|
||||
readerThreadId <- forkIO $ ircBotReader handle chan myOwnThreadId
|
||||
masterReaderThreadId <- forkIO $ ircBotMasterReader masterChan chan
|
||||
putStrLn "[IrcBot] Initializing server connection..."
|
||||
let ircServerState = IrcServerState { ircServerId = ircConfigAddress config
|
||||
, ircServerChannels = []
|
||||
, ircServerNickname = ircConfigNickname config
|
||||
, ircServerCommandPrefix = ircConfigCommandPrefix config
|
||||
, ircServerChan = chan }
|
||||
ircBotState = IrcBotState { ircBotStartTime = startTime
|
||||
, ircBotPlugins = M.empty
|
||||
, ircBotCommands = M.empty
|
||||
, ircBotChan = chan
|
||||
, ircBotMasterChan = masterChan
|
||||
, ircBotMyChan = myChan
|
||||
, ircBotServerState = ircServerState
|
||||
, ircBotHandle = handle
|
||||
, ircBotConfig = config
|
||||
, ircBotReaderThreadId = readerThreadId
|
||||
, ircBotMasterReaderThreadId = masterReaderThreadId }
|
||||
ircBotState' <- execStateT (initBotServerConnection config) ircBotState
|
||||
putStrLn "[IrcBot] Entering main loop... "
|
||||
_ <- ircBotLoop ircBotState' `catch` (\(_ :: IOException) -> return ())
|
||||
return ()
|
||||
|
||||
-- | 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' }
|
||||
|
||||
-- | IrcBot's loop that can catch ircbot's states' updates
|
||||
ircBotLoop :: IrcBotState -> IO ()
|
||||
ircBotLoop ircBotState = do
|
||||
putStrLn "[IrcBot] Spawning plugins..."
|
||||
ircBotState' <- execStateT spawnIrcPlugins ircBotState
|
||||
-- Todo : throw new ircbotstate to hsbot
|
||||
putStrLn "[IrcBot] Entering Core loop... "
|
||||
_ <- (execStateT ircBotCore ircBotState') -- `catch` (\(_ :: NewBotStateException) -> return ircBotState')
|
||||
return ()
|
||||
-- TODO : loop!
|
||||
|
||||
-- | Run the IrcBot's main loop
|
||||
ircBotCore :: IrcBot ()
|
||||
ircBotCore = forever $ do
|
||||
ircBot <- get
|
||||
let chan = ircBotChan ircBot
|
||||
msg <- liftIO $ readChan chan
|
||||
case msg of
|
||||
InIrcMsg inIrcMsg -> dispatchMessage $ InIrcMsg inIrcMsg
|
||||
OutIrcMsg outIrcMsg -> sendThisMessage outIrcMsg
|
||||
IntIrcCmd intIrcCmd -> do
|
||||
processInternalCommand $ IntIrcCmd intIrcCmd
|
||||
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) plugins'
|
||||
else
|
||||
mapM_ (sendToPlugin $ InIrcMsg inIrcMsg) (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 ()
|
||||
|
||||
|
|
@ -1,5 +1,8 @@
|
|||
module Hsbot.IRCParser
|
||||
( ParseError
|
||||
module Hsbot.Irc.Message
|
||||
( IrcBotMsg (..)
|
||||
, IrcCmd (..)
|
||||
, IrcMsg (..)
|
||||
, emptyIrcMsg
|
||||
, parseIrcMsg
|
||||
, serializeIrcMsg
|
||||
) where
|
||||
|
|
@ -7,7 +10,26 @@ module Hsbot.IRCParser
|
|||
import Control.Monad.Identity
|
||||
import Text.Parsec
|
||||
|
||||
import Hsbot.Types
|
||||
-- | 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
|
||||
80
Hsbot/Irc/Plugin.hs
Normal file
80
Hsbot/Irc/Plugin.hs
Normal file
|
|
@ -0,0 +1,80 @@
|
|||
module Hsbot.Irc.Plugin
|
||||
( IrcPlugin
|
||||
, IrcPluginState (..)
|
||||
, listPlugins
|
||||
, loadIrcPlugin
|
||||
, sendToPlugin
|
||||
, spawnIrcPlugins
|
||||
, unloadPlugin
|
||||
) 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.PluginCommons
|
||||
import Hsbot.Irc.Plugin.Core
|
||||
import Hsbot.Irc.Plugin.Dummy
|
||||
import Hsbot.Irc.Plugin.Ping
|
||||
import Hsbot.Irc.Plugin.Quote
|
||||
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
|
||||
-- We check for unicity
|
||||
case M.lookup pluginName oldPlugins of
|
||||
Just plugin -> return ()
|
||||
Nothing -> do
|
||||
threadId <- liftIO $ forkIO (entryPoint pluginChan masterChan)
|
||||
let plugin = IrcPluginState { ircPluginName = pluginName
|
||||
, ircPluginThreadId = threadId
|
||||
, ircPluginChan = pluginChan
|
||||
, ircPluginMasterChan = masterChan }
|
||||
put $ ircbot { ircBotPlugins = M.insert pluginName plugin oldPlugins }
|
||||
|
||||
-- | 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
|
||||
unloadPlugin :: String -> IrcBot ()
|
||||
unloadPlugin name = do
|
||||
bot <- get
|
||||
let oldPlugins = ircBotPlugins bot
|
||||
case M.lookup name oldPlugins of
|
||||
Just plugin -> do
|
||||
let newPlugins = M.delete name oldPlugins
|
||||
liftIO $ throwTo (ircPluginThreadId plugin) UserInterrupt
|
||||
put $ bot { ircBotPlugins = newPlugins }
|
||||
Nothing -> return ()
|
||||
|
||||
|
|
@ -1,20 +1,23 @@
|
|||
module Plugins.Core
|
||||
( mainCore
|
||||
module Hsbot.Irc.Plugin.Core
|
||||
( ircBotPluginCore
|
||||
) where
|
||||
|
||||
import Control.Concurrent.Chan(Chan)
|
||||
import Control.Concurrent (Chan, myThreadId)
|
||||
import Control.Exception
|
||||
import Control.Monad.State
|
||||
import Prelude hiding (catch)
|
||||
|
||||
import Hsbot.IRCPlugin
|
||||
import Hsbot.Types
|
||||
import Hsbot.Utils
|
||||
import Hsbot.Irc.Message
|
||||
import Hsbot.Irc.PluginCommons
|
||||
|
||||
-- | The plugin's main entry point
|
||||
mainCore :: Chan BotMsg -> Chan BotMsg -> IO ()
|
||||
mainCore serverChan chan = do
|
||||
let plugin = PluginState "Core" serverChan chan
|
||||
ircBotPluginCore :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
|
||||
ircBotPluginCore myChan masterChan = do
|
||||
threadId <- myThreadId
|
||||
let plugin = IrcPluginState { ircPluginName = "Core"
|
||||
, ircPluginThreadId = threadId
|
||||
, ircPluginChan = myChan
|
||||
, ircPluginMasterChan = masterChan }
|
||||
evalStateT (mapM_ sendRegisterCommand ["list", "load", "reload", "unload"]) plugin
|
||||
plugin' <- (execStateT run plugin) `catch` (\(_ :: AsyncException) -> return plugin)
|
||||
evalStateT (mapM_ sendUnregisterCommand ["list", "load", "reload", "unload"]) plugin'
|
||||
|
|
@ -25,21 +28,20 @@ run = forever $ do
|
|||
msg <- readMsg
|
||||
eval msg
|
||||
where
|
||||
eval :: BotMsg -> IrcPlugin ()
|
||||
eval (InternalCmd intCmd) = do
|
||||
let request = intCmdBotMsg intCmd
|
||||
case intCmdCmd intCmd of
|
||||
"RUN" -> let stuff = words $ intCmdMsg intCmd
|
||||
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
|
||||
_ -> lift . trace $ show intCmd -- TODO : help message
|
||||
"ANSWER" -> let stuff = intCmdMsg intCmd
|
||||
_ -> return () -- TODO : help message
|
||||
"ANSWER" -> let stuff = ircCmdMsg intCmd
|
||||
in answerMsg request ("Loaded plugins : " ++ stuff)
|
||||
_ -> lift . trace $ show intCmd
|
||||
eval (InputMsg _) = return ()
|
||||
_ -> return ()
|
||||
eval _ = return ()
|
||||
|
||||
-- | The list command
|
||||
30
Hsbot/Irc/Plugin/Dummy.hs
Normal file
30
Hsbot/Irc/Plugin/Dummy.hs
Normal file
|
|
@ -0,0 +1,30 @@
|
|||
module Hsbot.Irc.Plugin.Dummy
|
||||
( ircBotPluginDummy
|
||||
) where
|
||||
|
||||
import Control.Concurrent (myThreadId)
|
||||
import Control.Concurrent.Chan
|
||||
import Control.Exception
|
||||
import Control.Monad.State
|
||||
import Prelude hiding (catch)
|
||||
|
||||
import Hsbot.Irc.Message
|
||||
import Hsbot.Irc.PluginCommons
|
||||
|
||||
-- | The plugin's main entry point
|
||||
ircBotPluginDummy :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
|
||||
ircBotPluginDummy myChan masterChan = do
|
||||
threadId <- myThreadId
|
||||
let plugin = IrcPluginState { ircPluginName = "Dummy"
|
||||
, ircPluginThreadId = threadId
|
||||
, ircPluginChan = myChan
|
||||
, ircPluginMasterChan = masterChan }
|
||||
_ <- (execStateT run plugin) `catch` (\(_ :: AsyncException) -> return plugin)
|
||||
return ()
|
||||
|
||||
-- | The IrcPlugin monad main function
|
||||
run :: IrcPlugin ()
|
||||
run = forever $ do
|
||||
_ <- readMsg
|
||||
return ()
|
||||
|
||||
36
Hsbot/Irc/Plugin/Ping.hs
Normal file
36
Hsbot/Irc/Plugin/Ping.hs
Normal file
|
|
@ -0,0 +1,36 @@
|
|||
module Hsbot.Irc.Plugin.Ping
|
||||
( ircBotPluginPing
|
||||
) where
|
||||
|
||||
import Control.Concurrent (myThreadId)
|
||||
import Control.Concurrent.Chan
|
||||
import Control.Exception
|
||||
import Control.Monad.State
|
||||
import Prelude hiding (catch)
|
||||
|
||||
import Hsbot.Irc.Message
|
||||
import Hsbot.Irc.PluginCommons
|
||||
|
||||
-- | The plugin's main entry point
|
||||
ircBotPluginPing :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
|
||||
ircBotPluginPing myChan masterChan = do
|
||||
threadId <- myThreadId
|
||||
let plugin = IrcPluginState { ircPluginName = "Ping"
|
||||
, ircPluginThreadId = threadId
|
||||
, 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,7 +1,8 @@
|
|||
module Plugins.Quote
|
||||
( mainQuote
|
||||
module Hsbot.Irc.Plugin.Quote
|
||||
( ircBotPluginQuote
|
||||
) where
|
||||
|
||||
import Control.Concurrent (myThreadId)
|
||||
import Control.Concurrent.Chan
|
||||
import Control.Exception
|
||||
import Control.Monad.State
|
||||
|
|
@ -10,13 +11,15 @@ 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.IRCPlugin
|
||||
import Hsbot.Types
|
||||
import Hsbot.Utils
|
||||
import Hsbot.Irc.Message
|
||||
import Hsbot.Irc.PluginCommons
|
||||
|
||||
-- | A quote element
|
||||
data QuoteElt = QuoteElt
|
||||
|
|
@ -40,16 +43,29 @@ data QuoteBotState = QuoteBotState
|
|||
} deriving (Read, Show)
|
||||
|
||||
-- | The QuoteBot monad
|
||||
type QuoteBot a = StateT QuoteBotState (StateT PluginState IO) a
|
||||
type QuoteBot a = StateT QuoteBotState (StateT IrcPluginState IO) a
|
||||
|
||||
-- | The plugin's main entry point
|
||||
mainQuote :: Chan BotMsg -> Chan BotMsg -> IO ()
|
||||
mainQuote serverChan chan = do
|
||||
ircBotPluginQuote :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
|
||||
ircBotPluginQuote myChan masterChan = do
|
||||
-- First of all we restore the database
|
||||
txtQuoteBot <- TIO.readFile $ "quotedb.txt"
|
||||
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 = PluginState "Quote" serverChan chan
|
||||
threadId <- myThreadId
|
||||
let plugin = IrcPluginState { ircPluginName = "Quote"
|
||||
, ircPluginThreadId = threadId
|
||||
, ircPluginChan = myChan
|
||||
, ircPluginMasterChan = masterChan }
|
||||
evalStateT (mapM_ sendRegisterCommand ["quote"]) plugin
|
||||
_ <- (evalStateT (run quoteBot) plugin) `catch` (\(_ :: AsyncException) -> return quoteBot)
|
||||
evalStateT (mapM_ sendUnregisterCommand ["quote"]) plugin
|
||||
|
|
@ -62,30 +78,31 @@ run quoteBot = do
|
|||
run quoteBot'
|
||||
where
|
||||
-- | evaluate what we just received
|
||||
eval :: BotMsg -> IrcPlugin (QuoteBotState)
|
||||
eval (InternalCmd intCmd)
|
||||
| intCmdCmd intCmd == "RUN" = do
|
||||
eval :: IrcBotMsg -> IrcPlugin (QuoteBotState)
|
||||
eval (IntIrcCmd intCmd)
|
||||
| ircCmdCmd intCmd == "RUN" = do
|
||||
quoteBot' <- execStateT (runCommand intCmd) quoteBot
|
||||
return quoteBot'
|
||||
| otherwise = do
|
||||
lift . trace $ show intCmd
|
||||
return quoteBot
|
||||
eval (InputMsg _) = return (quoteBot)
|
||||
eval _ = return (quoteBot)
|
||||
| otherwise = return quoteBot
|
||||
eval (InIrcMsg _) = return (quoteBot)
|
||||
eval (OutIrcMsg _) = return (quoteBot)
|
||||
|
||||
-- | run a command we received
|
||||
runCommand :: IntCmd -> QuoteBot ()
|
||||
runCommand :: IrcCmd -> QuoteBot ()
|
||||
runCommand intCmd
|
||||
| theCommand == "quote" = runQuoteCommand
|
||||
| otherwise = do
|
||||
lift . lift . trace $ show intCmd -- TODO : help message
|
||||
| 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
|
||||
|
|
@ -94,7 +111,7 @@ runCommand intCmd
|
|||
| cmd == "start" = do
|
||||
quoteBot <- get
|
||||
now <- liftIO $ getCurrentTime
|
||||
let sender = takeWhile (/= '!') $ fromMaybe "ARGH" (prefix request)
|
||||
let sender = takeWhile (/= '!') $ fromMaybe "ARGH" (ircMsgPrefix request)
|
||||
newQuote = Quote sender [(quoteElt stuff)] now 0
|
||||
quoteId = nextQuoteId quoteBot
|
||||
quotesInProgress' = M.insert quoteId newQuote (quotesInProgress quoteBot)
|
||||
|
|
@ -134,17 +151,19 @@ runCommand intCmd
|
|||
theQuote = unwords . tail $ msg
|
||||
QuoteElt budy theQuote
|
||||
-- | utilities
|
||||
params = words . intCmdMsg $ intCmd
|
||||
params = words . ircCmdMsg $ intCmd
|
||||
theCommand = head params
|
||||
args = tail params
|
||||
stuff = tail args
|
||||
request = intCmdBotMsg intCmd
|
||||
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
|
||||
file' <- liftIO $ openFile "quotedb.txt" WriteMode
|
||||
liftIO . hPutStr file' $ show quoteBot
|
||||
liftIO $ hClose file'
|
||||
|
||||
67
Hsbot/Irc/PluginCommons.hs
Normal file
67
Hsbot/Irc/PluginCommons.hs
Normal file
|
|
@ -0,0 +1,67 @@
|
|||
module Hsbot.Irc.PluginCommons
|
||||
( 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
|
||||
, ircPluginThreadId :: ThreadId -- The plugin thread
|
||||
, 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
|
||||
|
||||
35
Hsbot/Irc/Server.hs
Normal file
35
Hsbot/Irc/Server.hs
Normal file
|
|
@ -0,0 +1,35 @@
|
|||
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)
|
||||
|
||||
48
Hsbot/Irc/Types.hs
Normal file
48
Hsbot/Irc/Types.hs
Normal file
|
|
@ -0,0 +1,48 @@
|
|||
module Hsbot.Irc.Types
|
||||
( IrcBot
|
||||
, IrcBotState (..)
|
||||
, IrcServer
|
||||
, IrcServerState (..)
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Monad.State
|
||||
import qualified Data.Map as M
|
||||
import Data.Time
|
||||
import System.IO
|
||||
|
||||
import Hsbot.Irc.Config
|
||||
import Hsbot.Irc.Message
|
||||
import Hsbot.Irc.PluginCommons
|
||||
import Hsbot.Message
|
||||
|
||||
-- | The Ircbot monad
|
||||
type IrcBot = StateT IrcBotState IO
|
||||
|
||||
-- | An Ircbot state
|
||||
data IrcBotState = IrcBotState
|
||||
{ ircBotStartTime :: UTCTime -- the bot's uptime
|
||||
, ircBotPlugins :: M.Map String IrcPluginState -- Loaded plugins
|
||||
, ircBotCommands :: M.Map String [String] -- Loaded plugins
|
||||
, ircBotChan :: Chan IrcBotMsg -- The IrcBot's communication channel
|
||||
, ircBotMasterChan :: Chan BotMsg -- The Hsbot communication channel
|
||||
, ircBotMyChan :: 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
|
||||
, ircBotReaderThreadId :: ThreadId
|
||||
, ircBotMasterReaderThreadId :: ThreadId
|
||||
}
|
||||
|
||||
-- | 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
|
||||
}
|
||||
|
||||
|
|
@ -1,36 +0,0 @@
|
|||
module Hsbot.Main
|
||||
( imain
|
||||
) where
|
||||
|
||||
import Control.Exception
|
||||
import Control.Monad.State
|
||||
import Prelude hiding (catch)
|
||||
import System.IO()
|
||||
|
||||
import Config
|
||||
import Hsbot.Core
|
||||
import Hsbot.IRC
|
||||
import Hsbot.Plugin
|
||||
import Hsbot.Types
|
||||
|
||||
import Plugins.Core(mainCore)
|
||||
import Plugins.Ping(mainPing)
|
||||
import Plugins.Quote(mainQuote)
|
||||
|
||||
-- | Bot's main entry point
|
||||
imain :: IO ()
|
||||
imain = do
|
||||
bot <- connectServer $ ircServer config
|
||||
bot' <- (execStateT run bot) `catch` (\(_ :: IOException) -> return bot)
|
||||
evalStateT disconnectServer bot'
|
||||
|
||||
-- | The Bot monad main function
|
||||
run :: IrcBot ()
|
||||
run = do
|
||||
initServer
|
||||
liftIO $ putStrLn "Starting plugins..."
|
||||
loadPlugin "Ping" mainPing
|
||||
loadPlugin "Core" mainCore
|
||||
loadPlugin "Quote" mainQuote
|
||||
runServer
|
||||
|
||||
15
Hsbot/Message.hs
Normal file
15
Hsbot/Message.hs
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
module Hsbot.Message
|
||||
( BotMsg (..)
|
||||
, Msg (..)
|
||||
) where
|
||||
|
||||
-- | A hsbot message
|
||||
data Msg = Msg
|
||||
{ msgType :: String -- the message type
|
||||
, msgFrom :: String -- who issues it
|
||||
, msgTo :: String -- who it is destinated to
|
||||
, msgCmd :: String -- the message to be transfered
|
||||
} deriving (Show)
|
||||
|
||||
data BotMsg = InMsg Msg | OutMsg Msg | IntMsg Msg deriving (Show)
|
||||
|
||||
|
|
@ -1,61 +1,24 @@
|
|||
module Hsbot.Plugin
|
||||
( listPlugins
|
||||
, loadPlugin
|
||||
, sendToPlugin
|
||||
, unloadPlugin
|
||||
( Plugin
|
||||
, PluginState (..)
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.Chan ()
|
||||
import Control.Exception
|
||||
import Control.Monad.State
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe()
|
||||
import System.IO()
|
||||
import IO (Handle)
|
||||
|
||||
import Hsbot.Types
|
||||
import Hsbot.Utils
|
||||
import Hsbot.Message
|
||||
|
||||
-- | Loads a plugin into an ircBot
|
||||
loadPlugin :: String -> (Chan BotMsg -> Chan BotMsg -> IO ()) -> IrcBot ()
|
||||
loadPlugin name entryPoint = do
|
||||
bot <- get
|
||||
let oldPlugins = botPlugins bot
|
||||
plugin <- liftIO $ effectivelyLoadPlugin name entryPoint (botChannel bot)
|
||||
put $ bot { botPlugins = M.insert name plugin oldPlugins}
|
||||
-- | The Plugin monad
|
||||
type Plugin = StateT PluginState IO
|
||||
|
||||
-- | Effectively try to load a plugin
|
||||
effectivelyLoadPlugin :: String -> (Chan BotMsg -> Chan BotMsg -> IO ()) -> Chan BotMsg -> IO (Plugin)
|
||||
effectivelyLoadPlugin name entryPoint serverChan = do
|
||||
putStrLn $ inColor ("Loaded (static) plugin: " ++ name) [32]
|
||||
chan <- newChan :: IO (Chan BotMsg)
|
||||
threadId <- forkIO $ entryPoint serverChan chan
|
||||
return $ Plugin name threadId chan
|
||||
|
||||
-- | Sends a list of loaded plugins
|
||||
listPlugins :: IrcMsg -> String -> IrcBot ()
|
||||
listPlugins originalRequest dest = do
|
||||
plugins <- gets botPlugins
|
||||
let listing = unwords $ M.keys plugins
|
||||
case M.lookup dest plugins of
|
||||
Just plugin -> sendToPlugin (InternalCmd $ IntCmd "ANSWER" "CORE" dest listing originalRequest) plugin
|
||||
Nothing -> return ()
|
||||
|
||||
-- | Unloads a plugin
|
||||
unloadPlugin :: String -> IrcBot ()
|
||||
unloadPlugin name = do
|
||||
bot <- get
|
||||
let oldPlugins = botPlugins bot
|
||||
case M.lookup name oldPlugins of
|
||||
Just plugin -> do
|
||||
let newPlugins = M.delete name oldPlugins
|
||||
liftIO $ throwTo (pluginThreadId plugin) UserInterrupt
|
||||
put $ bot { botPlugins = newPlugins }
|
||||
Nothing -> return ()
|
||||
|
||||
-- | Sends a msg to a plugin
|
||||
sendToPlugin :: BotMsg -> Plugin -> IrcBot ()
|
||||
sendToPlugin msg plugin = do
|
||||
let chan = pluginChannel plugin
|
||||
liftIO $ writeChan chan msg
|
||||
-- | A plugin state
|
||||
data PluginState = PluginState
|
||||
{ pluginName :: String -- The plugin's name
|
||||
, pluginThreadId :: ThreadId -- The plugin thread
|
||||
, pluginChan :: Chan BotMsg -- The plugin chan
|
||||
, pluginHandles :: M.Map String Handle -- the plugins's handles
|
||||
}
|
||||
|
||||
|
|
|
|||
108
Hsbot/Types.hs
108
Hsbot/Types.hs
|
|
@ -1,108 +0,0 @@
|
|||
module Hsbot.Types
|
||||
( Bot(..)
|
||||
, BotMsg(..)
|
||||
, Channel(..)
|
||||
, Config(..)
|
||||
, IntCmd(..)
|
||||
, IrcServer(..)
|
||||
, IrcBot
|
||||
, IrcMsg(..)
|
||||
, Plugin(..)
|
||||
, emptyIrcMsg
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.Chan()
|
||||
import Control.Monad.State
|
||||
import qualified Data.Map as M
|
||||
import Network
|
||||
import System.IO
|
||||
import System.Time (ClockTime)
|
||||
|
||||
-- | TODO : a monad for a channel, and a monad for a server, all together driven by a Bot?
|
||||
|
||||
-- | Configuration data type
|
||||
data Config = Config
|
||||
{ commandPrefix :: Char -- command prefixe, for example @[\'>\',\'@\',\'?\']@
|
||||
, ircServer :: IrcServer -- list of 'Server's to connect to
|
||||
} deriving (Show)
|
||||
|
||||
-- | An IRC server
|
||||
data IrcServer = IrcServer
|
||||
{ serverAddress :: String -- the server's address
|
||||
, serverPort :: PortID -- the server's port
|
||||
, joinChannels :: [String] -- a list of channels to join
|
||||
, nickname :: String -- the hsbot's nickname
|
||||
, password :: String -- the hsbot's password, optional
|
||||
, realname :: String -- the hsbot's real name, optional
|
||||
, administrators :: [String] -- bot admins nicknames
|
||||
}
|
||||
|
||||
instance Show IrcServer where
|
||||
show (IrcServer a p c n pa r ad) = (show a)
|
||||
++ (case p of
|
||||
PortNumber num -> show num
|
||||
Service s -> show s
|
||||
UnixSocket u -> show u)
|
||||
++ (show c) ++ (show n) ++ (show pa) ++ (show r) ++ (show ad)
|
||||
|
||||
-- | The IrcBot monad
|
||||
type IrcBot a = StateT Bot IO a
|
||||
|
||||
-- | An IRC Bot server state
|
||||
data Bot = Bot
|
||||
{ serverConfig :: IrcServer -- original server config we are connected to
|
||||
, startTime :: ClockTime -- the bot's uptime
|
||||
, botHandle :: Handle -- the socket/handle
|
||||
, chans :: [Channel] -- the list of channels we have joined
|
||||
, botPlugins :: M.Map String Plugin -- Loaded plugins
|
||||
, botChannel :: Chan BotMsg -- The bot's communication channel
|
||||
, readerThreadId :: ThreadId -- The bot's thread ID
|
||||
, botCommands :: M.Map String [String] -- Registered commands ("command", ["pluginName"])
|
||||
}
|
||||
|
||||
instance Show Bot where
|
||||
show (Bot _ s h c p _ _ cmds) = unlines [ "Start time : " ++ (show s)
|
||||
, "Handle : " ++ (show h)
|
||||
, "Channels : " ++ (show c)
|
||||
, "Plugins : " ++ (show p)
|
||||
, "Commands : " ++ (show cmds)]
|
||||
|
||||
-- | A channel connection
|
||||
data Channel = Channel
|
||||
{ channelName :: String -- the channel's name
|
||||
, channelNick :: String -- our nickname
|
||||
, channelAdmins :: [String] -- the bot administrators
|
||||
} deriving (Show)
|
||||
|
||||
-- | An IRC message
|
||||
data IrcMsg = IrcMsg
|
||||
{ prefix :: Maybe String -- the message prefix
|
||||
, command :: String -- the message command
|
||||
, parameters :: [String] -- the message parameters
|
||||
} deriving (Show)
|
||||
|
||||
emptyIrcMsg :: IrcMsg
|
||||
emptyIrcMsg = IrcMsg Nothing "" []
|
||||
|
||||
-- | An internal command
|
||||
data IntCmd = IntCmd
|
||||
{ intCmdCmd :: String -- the internal command
|
||||
, intCmdFrom :: String -- who issues it
|
||||
, intCmdTo :: String -- who it is destinated to
|
||||
, intCmdMsg :: String -- the message to be transfered
|
||||
, intCmdBotMsg :: IrcMsg -- An IrcMsg attached to the command
|
||||
} deriving (Show)
|
||||
|
||||
data BotMsg = InputMsg IrcMsg | OutputMsg IrcMsg | InternalCmd IntCmd deriving (Show)
|
||||
|
||||
-- | A plugin (core side)
|
||||
data Plugin = Plugin
|
||||
{ pluginName :: String -- The plugin's name
|
||||
, pluginThreadId :: ThreadId -- The plugin thread
|
||||
, pluginChannel :: Chan BotMsg -- The plugin channel
|
||||
}
|
||||
|
||||
instance Show Plugin where
|
||||
show (Plugin name _ _) = show name
|
||||
|
||||
|
|
@ -1,42 +0,0 @@
|
|||
module Hsbot.Utils
|
||||
( error
|
||||
, errorM
|
||||
, inColor
|
||||
, sendstr
|
||||
, trace
|
||||
, traceM
|
||||
) where
|
||||
|
||||
import Control.Monad.State
|
||||
import Data.List
|
||||
import System.IO
|
||||
|
||||
import Hsbot.Types
|
||||
|
||||
-- |Wrap a string with ANSI escape sequences.
|
||||
inColor :: String -> [Int] -> String
|
||||
inColor str vals = "\ESC[" ++ valstr ++ "m" ++ str ++ "\ESC[0m"
|
||||
where valstr = concat . intersperse ";" $ map show vals
|
||||
|
||||
-- | Sends a string over handle
|
||||
sendstr :: String -> IrcBot ()
|
||||
sendstr str = do
|
||||
handle <- gets botHandle
|
||||
traceM $ inColor ("--> " ++ str) [33]
|
||||
liftIO $ hPutStr handle (str ++ "\r\n")
|
||||
|
||||
-- | Log a message string
|
||||
trace :: String -> IO ()
|
||||
trace msg = putStrLn msg
|
||||
|
||||
-- | Log a message string
|
||||
traceM :: String -> IrcBot ()
|
||||
traceM msg = liftIO $ trace msg
|
||||
|
||||
-- | Logs an error message
|
||||
traceRed :: String -> IO ()
|
||||
traceRed msg = trace $ inColor msg [31]
|
||||
|
||||
errorM :: String -> IrcBot ()
|
||||
errorM msg = liftIO $ traceRed msg
|
||||
|
||||
55
Main.hs
55
Main.hs
|
|
@ -1,9 +1,58 @@
|
|||
module Main where
|
||||
module Main (main) where
|
||||
|
||||
import Hsbot
|
||||
import Control.Monad (when)
|
||||
import Prelude hiding (catch)
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.Exit
|
||||
import System.FilePath
|
||||
import System.Info
|
||||
import System.IO
|
||||
import System.Posix.Process (executeFile)
|
||||
import System.Process
|
||||
|
||||
-- | Dynamic launching function
|
||||
main :: IO ()
|
||||
main = do
|
||||
imain
|
||||
args <- getArgs
|
||||
case args of
|
||||
[] -> buildLaunch
|
||||
["--help"] -> usage
|
||||
_ -> fail "unrecognized flags"
|
||||
|
||||
usage :: IO ()
|
||||
usage = do
|
||||
self <- getProgName
|
||||
putStr . unlines $
|
||||
concat ["Usage: ", self, " [OPTION]"] :
|
||||
"Options:" :
|
||||
" --help : Print this message" :
|
||||
[]
|
||||
|
||||
buildLaunch :: IO ()
|
||||
buildLaunch = do
|
||||
_ <- recompile
|
||||
dir <- getAppUserDataDirectory "hsbot"
|
||||
args <- getArgs
|
||||
_ <- executeFile (dir ++ "/hsbot-" ++ arch ++ "-" ++ os) False args Nothing
|
||||
return ()
|
||||
|
||||
recompile :: IO (Bool)
|
||||
recompile = do
|
||||
dir <- getAppUserDataDirectory "hsbot"
|
||||
let binn = "hsbot-"++arch++"-"++os
|
||||
base = dir </> "hsbot"
|
||||
err = base ++ ".errors"
|
||||
src = base ++ ".hs"
|
||||
errorHandle <- openFile err WriteMode
|
||||
exitCode <- waitForProcess =<< runProcess "ghc" ["--make", "hsbot.hs", "-fforce-recomp", "-XScopedTypeVariables", "-o", binn] (Just dir)
|
||||
Nothing Nothing Nothing (Just errorHandle)
|
||||
hClose errorHandle
|
||||
when (exitCode /= ExitSuccess) $ do
|
||||
ghcErr <- readFile err
|
||||
let msg = unlines $
|
||||
["Error detected while loading hsbot configuration file: " ++ src]
|
||||
++ lines ghcErr ++ ["","Please check the file for errors."]
|
||||
hPutStrLn stderr msg
|
||||
return (exitCode == ExitSuccess)
|
||||
|
||||
|
|
|
|||
14
Makefile
14
Makefile
|
|
@ -1,14 +0,0 @@
|
|||
all:
|
||||
ghc --make -Wall -O2 Main.hs -o hsbot -XScopedTypeVariables
|
||||
|
||||
listen:
|
||||
nc -l 127.0.0.1 6667
|
||||
|
||||
run:
|
||||
runghc -XScopedTypeVariables Main
|
||||
|
||||
clean:
|
||||
- rm hsbot
|
||||
- find ./ -name \*.o -exec rm {} \;
|
||||
- find ./ -name \*.hi -exec rm {} \;
|
||||
|
||||
|
|
@ -1,31 +0,0 @@
|
|||
module Plugins.Ping
|
||||
( mainPing
|
||||
) where
|
||||
|
||||
import Control.Concurrent.Chan
|
||||
import Control.Exception
|
||||
import Control.Monad.State
|
||||
import Prelude hiding (catch)
|
||||
|
||||
import Hsbot.IRCPlugin
|
||||
import Hsbot.Types
|
||||
|
||||
-- | The plugin's main entry point
|
||||
mainPing :: Chan BotMsg -> Chan BotMsg -> IO ()
|
||||
mainPing serverChan chan = do
|
||||
let plugin = PluginState "Ping" serverChan chan
|
||||
_ <- (execStateT run plugin) `catch` (\(_ :: AsyncException) -> return plugin)
|
||||
return ()
|
||||
|
||||
-- | The IrcPlugin monad main function
|
||||
run :: IrcPlugin ()
|
||||
run = forever $ do
|
||||
msg <- readMsg
|
||||
eval msg
|
||||
where
|
||||
eval :: BotMsg -> IrcPlugin ()
|
||||
eval (InputMsg msg)
|
||||
| (command msg) == "PING" = writeMsg $ OutputMsg $ IrcMsg Nothing "PONG" (parameters msg)
|
||||
| otherwise = return ()
|
||||
eval _ = return ()
|
||||
|
||||
5
README
5
README
|
|
@ -1,5 +0,0 @@
|
|||
Dependances :
|
||||
-------------
|
||||
hs-plugin
|
||||
text
|
||||
|
||||
5
Setup.hs
Normal file
5
Setup.hs
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
#!/usr/bin/env runhaskell
|
||||
|
||||
import Distribution.Simple
|
||||
|
||||
main = defaultMain
|
||||
3
TODO
3
TODO
|
|
@ -1,5 +1,8 @@
|
|||
:julien!~julien@ogu21.corp PRIVMSG #shbot :@quote graou snif
|
||||
|
||||
* Handle bot/Plugin state updates threw the masters' Chans
|
||||
* Find a way to handle bot reloading threw exec
|
||||
|
||||
* write the vote system for the quote module
|
||||
* only the quote reporter should be able to edit it
|
||||
* detect too identical quoting in a raw, or implement quote abort
|
||||
|
|
|
|||
73
hsbot.cabal
Normal file
73
hsbot.cabal
Normal file
|
|
@ -0,0 +1,73 @@
|
|||
name: hsbot
|
||||
version: 0.1.0
|
||||
cabal-version: >= 1.8
|
||||
build-type: Simple
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
copyright: Copyright (c) 2010 Julien Dessaux
|
||||
author: Julien Dessaux
|
||||
maintainer: judessaux@gmail.com
|
||||
homepage: http://code.adyxax.org/hsbot
|
||||
bug-reports: http://code.adyxax.org/hsbot/tracker
|
||||
category: Hsbot
|
||||
synopsis: An multi-purpose bot, mainly an IRC bot
|
||||
description:
|
||||
hsbot is a multi-purpose bot, written slowly, as long as I learned more
|
||||
haskell. It features IRC integration and some plugins. I tried to design
|
||||
a bot architecture as modular and as flexible as possible.
|
||||
|
||||
Executable hsbot
|
||||
Main-Is: Main.hs
|
||||
ghc-options: -Wall
|
||||
extensions: DeriveDataTypeable ScopedTypeVariables
|
||||
build-depends: base >= 4.1,
|
||||
containers >= 0.3,
|
||||
directory >= 1.0,
|
||||
filepath >= 1.1,
|
||||
ghc >= 6.12,
|
||||
haskell98 >= 1.0,
|
||||
mtl >= 1.1,
|
||||
network >= 2.2,
|
||||
old-time >= 1.0,
|
||||
parsec >= 3.1,
|
||||
process >= 1.0,
|
||||
random >= 1.0,
|
||||
text >= 0.7,
|
||||
time >= 1.1,
|
||||
unix >= 2.4
|
||||
|
||||
Library
|
||||
exposed-modules:
|
||||
Hsbot.Config
|
||||
Hsbot.Core
|
||||
Hsbot.Irc.Command
|
||||
Hsbot.Irc.Config
|
||||
Hsbot.Irc.Core
|
||||
Hsbot.Irc.Message
|
||||
Hsbot.Irc.Plugin
|
||||
Hsbot.Irc.PluginCommons
|
||||
Hsbot.Irc.Plugin.Core
|
||||
Hsbot.Irc.Plugin.Dummy
|
||||
Hsbot.Irc.Plugin.Ping
|
||||
Hsbot.Irc.Plugin.Quote
|
||||
Hsbot.Irc.Server
|
||||
Hsbot.Irc.Types
|
||||
Hsbot.Message
|
||||
Hsbot.Plugin
|
||||
ghc-options: -Wall
|
||||
extensions: DeriveDataTypeable ScopedTypeVariables
|
||||
build-depends: base >= 4.1,
|
||||
containers >= 0.3,
|
||||
directory >= 1.0,
|
||||
filepath >= 1.1,
|
||||
ghc >= 6.12,
|
||||
haskell98 >= 1.0,
|
||||
mtl >= 1.1,
|
||||
network >= 2.2,
|
||||
old-time >= 1.0,
|
||||
parsec >= 3.1,
|
||||
random >= 1.0,
|
||||
text >= 0.7,
|
||||
time >= 1.1,
|
||||
unix >= 2.4
|
||||
|
||||
Reference in a new issue