summaryrefslogtreecommitdiff
path: root/HsbotMaster
diff options
context:
space:
mode:
Diffstat (limited to 'HsbotMaster')
-rw-r--r--HsbotMaster/.gitignore2
-rw-r--r--HsbotMaster/Hsbot/.gitignore2
-rw-r--r--HsbotMaster/Hsbot/Config.hs9
-rw-r--r--HsbotMaster/Hsbot/Core.hs91
-rw-r--r--HsbotMaster/Hsbot/Message.hs35
-rw-r--r--HsbotMaster/Hsbot/Plugin.hs67
-rw-r--r--HsbotMaster/Hsbot/PluginUtils.hs15
-rw-r--r--HsbotMaster/Hsbot/Types.hs75
-rw-r--r--HsbotMaster/Main.hs58
-rw-r--r--HsbotMaster/Setup.hs5
-rw-r--r--HsbotMaster/hsbot.cabal63
11 files changed, 422 insertions, 0 deletions
diff --git a/HsbotMaster/.gitignore b/HsbotMaster/.gitignore
new file mode 100644
index 0000000..a5aa1b9
--- /dev/null
+++ b/HsbotMaster/.gitignore
@@ -0,0 +1,2 @@
+.*.swp
+Session.vim
diff --git a/HsbotMaster/Hsbot/.gitignore b/HsbotMaster/Hsbot/.gitignore
new file mode 100644
index 0000000..a5aa1b9
--- /dev/null
+++ b/HsbotMaster/Hsbot/.gitignore
@@ -0,0 +1,2 @@
+.*.swp
+Session.vim
diff --git a/HsbotMaster/Hsbot/Config.hs b/HsbotMaster/Hsbot/Config.hs
new file mode 100644
index 0000000..121cc98
--- /dev/null
+++ b/HsbotMaster/Hsbot/Config.hs
@@ -0,0 +1,9 @@
+module Hsbot.Config
+ ( BotConfig (..)
+ ) where
+
+import Hsbot.Irc.Config
+
+-- | Configuration data type
+data BotConfig = IrcBotConfig IrcConfig
+
diff --git a/HsbotMaster/Hsbot/Core.hs b/HsbotMaster/Hsbot/Core.hs
new file mode 100644
index 0000000..dad965d
--- /dev/null
+++ b/HsbotMaster/Hsbot/Core.hs
@@ -0,0 +1,91 @@
+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" }
+
diff --git a/HsbotMaster/Hsbot/Message.hs b/HsbotMaster/Hsbot/Message.hs
new file mode 100644
index 0000000..933394b
--- /dev/null
+++ b/HsbotMaster/Hsbot/Message.hs
@@ -0,0 +1,35 @@
+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
+
diff --git a/HsbotMaster/Hsbot/Plugin.hs b/HsbotMaster/Hsbot/Plugin.hs
new file mode 100644
index 0000000..1493c73
--- /dev/null
+++ b/HsbotMaster/Hsbot/Plugin.hs
@@ -0,0 +1,67 @@
+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 ()
+
diff --git a/HsbotMaster/Hsbot/PluginUtils.hs b/HsbotMaster/Hsbot/PluginUtils.hs
new file mode 100644
index 0000000..d09b3b4
--- /dev/null
+++ b/HsbotMaster/Hsbot/PluginUtils.hs
@@ -0,0 +1,15 @@
+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
+
diff --git a/HsbotMaster/Hsbot/Types.hs b/HsbotMaster/Hsbot/Types.hs
new file mode 100644
index 0000000..66b4d6b
--- /dev/null
+++ b/HsbotMaster/Hsbot/Types.hs
@@ -0,0 +1,75 @@
+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)
+
diff --git a/HsbotMaster/Main.hs b/HsbotMaster/Main.hs
new file mode 100644
index 0000000..5e528ca
--- /dev/null
+++ b/HsbotMaster/Main.hs
@@ -0,0 +1,58 @@
+module Main (main) where
+
+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
+ 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)
+
diff --git a/HsbotMaster/Setup.hs b/HsbotMaster/Setup.hs
new file mode 100644
index 0000000..14a7f90
--- /dev/null
+++ b/HsbotMaster/Setup.hs
@@ -0,0 +1,5 @@
+#!/usr/bin/env runhaskell
+
+import Distribution.Simple
+
+main = defaultMain
diff --git a/HsbotMaster/hsbot.cabal b/HsbotMaster/hsbot.cabal
new file mode 100644
index 0000000..fcf5533
--- /dev/null
+++ b/HsbotMaster/hsbot.cabal
@@ -0,0 +1,63 @@
+name: hsbot
+version: 0.2.1
+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 && < 5,
+ directory >= 1.0,
+ filepath >= 1.1,
+ process >= 1.0,
+ 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.Plugin.Core
+ Hsbot.Irc.Plugin.Dummy
+ Hsbot.Irc.Plugin.Ping
+ Hsbot.Irc.Plugin.Quote
+ Hsbot.Irc.Plugin.Utils
+ Hsbot.Irc.Server
+ Hsbot.Irc.Types
+ Hsbot.Message
+ Hsbot.Plugin
+ Hsbot.PluginUtils
+ Hsbot.Types
+ ghc-options: -Wall
+ extensions: DeriveDataTypeable ScopedTypeVariables
+ build-depends: base >= 4.1 && < 5,
+ containers >= 0.3,
+ directory >= 1.0,
+ filepath >= 1.1,
+ haskell98 >= 1.0,
+ mtl >= 1.1,
+ network >= 2.2,
+ parsec >= 3.1,
+ random >= 1.0,
+ text >= 0.7,
+ time >= 1.1,
+ unix >= 2.4
+
generated by cgit v1.2.3 (git 2.39.1) at 2024-10-05 15:26:08 +0000