Moved files around as a preliminary for architectural changes.

HsbotMaster/.gitignore

@@ -0,0 +1,2 @@
+.*.swp
+Session.vim

HsbotMaster/Hsbot/.gitignore

@@ -0,0 +1,2 @@
+.*.swp
+Session.vim

HsbotMaster/Hsbot/Config.hs

@@ -0,0 +1,9 @@
+module Hsbot.Config
+    ( BotConfig (..)
+    ) where
+
+import Hsbot.Irc.Config
+
+-- | Configuration data type
+data BotConfig = IrcBotConfig IrcConfig
+

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" }
+

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
+

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 ()
+

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
+

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)
+

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)
+

HsbotMaster/Setup.hs

@@ -0,0 +1,5 @@
+#!/usr/bin/env runhaskell
+
+import Distribution.Simple
+
+main = defaultMain

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
+