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

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

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
-

Hsbot/Command.hs

@@ -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]
-

Hsbot/Config.hs

@@ -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 = []
+    }
+

Hsbot/Core.hs

@@ -1,71 +1,69 @@
 module Hsbot.Core
-    ( connectServer
+    ( hsbot
-    , disconnectServer
     ) where
 
 import Control.Concurrent
-import Control.Concurrent.Chan()
+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.IO()
-import System.Time (getClockTime)
 
-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
+-- | The Bot monad
-connectServer :: IrcServer -> IO Bot
+type Bot = StateT BotState IO
-connectServer server = do
+
-    let name  = serverAddress server
+-- | An Hsbot state
-    starttime <- getClockTime
+data BotState = BotState
-    putStr $ "Connecting to " ++ name ++ "... "
+    { botStartTime :: UTCTime                  -- the bot's uptime
-    handle <- connectTo name $ serverPort server
+    , botPlugins   :: M.Map String PluginState -- Loaded plugins
-    hSetBuffering handle NoBuffering
+    , botChan      :: Chan BotMsg              -- The bot's communication channel
-    putStrLn "done."
+    , botConfig    :: Config                   -- the bot's starting config
-    putStr "Opening server communication channel... "
+    }
+
+-- | 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
+    putStrLn "[Hsbot] Spawning IrcBot plugins... "
-    threadId <- forkIO $ botReader handle chan myFatherThreadId
+    botState <- execStateT spawnIrcPlugins BotState { botStartTime = startTime
-    putStrLn "done."
+                                                    , botPlugins   = M.empty
-    return $ Bot server starttime handle [] M.empty chan threadId M.empty
+                                                    , botChan      = chan
+                                                    , botConfig    = config }
+    putStrLn "[Hsbot] Entering main loop... "
+    botState' <- (execStateT botLoop botState) `catch` (\(_ :: IOException) -> return botState)
+    return ()
 
--- | Disconnect from the server
+-- | Run the bot main loop
-disconnectServer :: IrcBot ()
+botLoop :: Bot ()
-disconnectServer = do
+botLoop = forever $ do
-    bot <- get
+    chan <- gets botChan
-    let name = serverAddress $ serverConfig bot
+    msg <- liftIO $ readChan chan
-    liftIO $ putStr "Shutting down plugins..."
+    -- process messages
-    mapM_ unloadPlugin (M.keys $ botPlugins bot)
+    return ()
-    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
+-- | spawns IrcPlugins
-botReader :: Handle -> Chan BotMsg -> ThreadId -> IO ()
+spawnIrcPlugins :: Bot ()
-botReader handle chan fatherThreadId = forever $ do
+spawnIrcPlugins = do
-    str <- (hGetLine handle) `catch` handleIOException
+    config <- gets botConfig
-    let msg = parseIrcMsg str
+    mapM_ (spawnIrcPlugin) (ircConfigs config)
-    case msg of
-        Right msg' -> do
-            trace $ inColor ("<-- " ++ (show msg')) [33]
-            writeChan chan (InputMsg msg')
-        _ -> do
-            return ()
   where
-    handleIOException :: IOException -> IO (String)
+    spawnIrcPlugin :: IrcConfig -> Bot ()
-    handleIOException ioException = do
+    spawnIrcPlugin config = do
-        throwTo fatherThreadId ioException
+        bot <- get
-        myId <- myThreadId
+        let chan  = botChan bot
-        killThread myId
+        pchan <- liftIO (newChan :: IO (Chan BotMsg))
-        return ""
+        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 }
 

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

Hsbot/IRCPlugin.hs

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

Hsbot/Irc/Command.hs

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

Hsbot/Irc/Config.hs

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

Hsbot/Irc/Core.hs

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

Hsbot/Irc/Message.hs

@@ -1,5 +1,8 @@
-module Hsbot.IRCParser
+module Hsbot.Irc.Message
-    ( ParseError
+    ( 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
@@ -38,7 +60,7 @@ pLongParam = char ':' >> (many1 (noneOf "\r"))
 pShortParam :: ParsecT String u Identity [Char]
 pShortParam = many1 (noneOf " \r")
 
--- |Serialize an IRC message to a string.
+-- | Serialize an IRC message to a string.
 serializeIrcMsg :: IrcMsg -> String
 serializeIrcMsg (IrcMsg pfx cmd params) = pfxStr ++ cmd ++ paramStr
     where pfxStr = case pfx of

Hsbot/Irc/Plugin.hs

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

Hsbot/Irc/Plugin/Core.hs

@@ -1,20 +1,23 @@
-module Plugins.Core
+module Hsbot.Irc.Plugin.Core
-    ( mainCore
+    ( 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.Irc.Message
-import Hsbot.Types
+import Hsbot.Irc.PluginCommons
-import Hsbot.Utils
 
 -- | The plugin's main entry point
-mainCore :: Chan BotMsg -> Chan BotMsg -> IO ()
+ircBotPluginCore :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
-mainCore serverChan chan = do
+ircBotPluginCore myChan masterChan = do
-    let plugin = PluginState "Core" serverChan chan
+    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 :: IrcBotMsg -> IrcPlugin ()
-    eval (InternalCmd intCmd) = do
+    eval (IntIrcCmd intCmd) = do
-        let request = intCmdBotMsg intCmd
+        let request = ircCmdBotMsg intCmd
-        case intCmdCmd intCmd of
+        case ircCmdCmd intCmd of
-            "RUN"    -> let stuff = words $ intCmdMsg intCmd
+            "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
+                            _        -> return () -- TODO : help message
-            "ANSWER" -> let stuff = intCmdMsg intCmd
+            "ANSWER" -> let stuff = ircCmdMsg intCmd
                         in answerMsg request ("Loaded plugins : " ++ stuff)
-            _        -> lift . trace $ show intCmd
+            _        -> return ()
-    eval (InputMsg _) = return ()
     eval _ = return ()
 
 -- | The list command

Hsbot/Irc/Plugin/Dummy.hs

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

Hsbot/Irc/Plugin/Ping.hs

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

Hsbot/Irc/Plugin/Quote.hs

@@ -1,7 +1,8 @@
-module Plugins.Quote
+module Hsbot.Irc.Plugin.Quote
-    ( mainQuote
+    ( 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.Irc.Message
-import Hsbot.Types
+import Hsbot.Irc.PluginCommons
-import Hsbot.Utils
 
 -- | 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 ()
+ircBotPluginQuote :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
-mainQuote serverChan chan = do
+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 :: IrcBotMsg -> IrcPlugin (QuoteBotState)
-    eval (InternalCmd intCmd)
+    eval (IntIrcCmd intCmd)
-      | intCmdCmd intCmd == "RUN" = do
+      | ircCmdCmd intCmd == "RUN" = do
           quoteBot' <- execStateT (runCommand intCmd) quoteBot
           return quoteBot'
-      | otherwise = do
+      | otherwise = return quoteBot
-          lift . trace $ show intCmd
+    eval (InIrcMsg _) = return (quoteBot)
-          return quoteBot
+    eval (OutIrcMsg _) = return (quoteBot)
-    eval (InputMsg _) = return (quoteBot)
-    eval _ = return (quoteBot)
 
 -- | run a command we received
-runCommand :: IntCmd -> QuoteBot ()
+runCommand :: IrcCmd -> QuoteBot ()
 runCommand intCmd
   | theCommand == "quote" = runQuoteCommand
-  | otherwise = do
+  | otherwise = return ()
-      lift . lift . trace $ show intCmd -- TODO : help message
   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)
-          mapM_ (lift . answerMsg request) (formatQuote (M.keys quoteDB !! x) (M.elems quoteDB !! x))
+          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'
 

Hsbot/Irc/PluginCommons.hs

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

Hsbot/Irc/Server.hs

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

Hsbot/Irc/Types.hs

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

Hsbot/Main.hs

@@ -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
-

Hsbot/Message.hs

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

Hsbot/Plugin.hs

@@ -1,61 +1,24 @@
 module Hsbot.Plugin
-    ( listPlugins
+    ( Plugin
-    , loadPlugin
+    , PluginState (..)
-    , sendToPlugin
-    , unloadPlugin
     ) where
 
 import Control.Concurrent
-import Control.Concurrent.Chan()
+import Control.Concurrent.Chan ()
-import Control.Exception
 import Control.Monad.State
 import qualified Data.Map as M
-import Data.Maybe()
+import IO (Handle)
-import System.IO()
 
-import Hsbot.Types
+import Hsbot.Message
-import Hsbot.Utils
 
--- | Loads a plugin into an ircBot
+-- | The Plugin monad
-loadPlugin :: String -> (Chan BotMsg -> Chan BotMsg -> IO ()) -> IrcBot ()
+type Plugin = StateT PluginState IO
-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}
 
--- | Effectively try to load a plugin
+-- | A plugin state
-effectivelyLoadPlugin :: String -> (Chan BotMsg -> Chan BotMsg -> IO ()) -> Chan BotMsg -> IO (Plugin)
+data PluginState = PluginState
-effectivelyLoadPlugin name entryPoint serverChan = do
+    { pluginName       :: String              -- The plugin's name
-    putStrLn $ inColor ("Loaded (static) plugin: " ++ name) [32]
+    , pluginThreadId   :: ThreadId            -- The plugin thread
-    chan <- newChan :: IO (Chan BotMsg)
+    , pluginChan       :: Chan BotMsg         -- The plugin chan
-    threadId <- forkIO $ entryPoint serverChan chan
+    , pluginHandles    :: M.Map String Handle -- the plugins's handles
-    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
 

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
-

Hsbot/Utils.hs

@@ -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
-

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)
 

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 {} \;
-

Plugins/Ping.hs

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

README

@@ -1,5 +0,0 @@
-Dependances :
--------------
-hs-plugin
-text
-

Setup.hs

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

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

hsbot.cabal

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