Rewrote nearly everything!v0.2.0

* 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

6 files changed, 278 insertions, 44 deletions

diff --git a/Hsbot/Irc/Plugin.hs b/Hsbot/Irc/Plugin.hs
new file mode 100644
index 0000000..b12d922
--- /dev/null
+++ b/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 ()
+
diff --git a/Plugins/Core.hs b/Hsbot/Irc/Plugin/Core.hs
index f81f4bf..5d69ca3 100644
--- a/Plugins/Core.hs
+++ b/Hsbot/Irc/Plugin/Core.hs
@@ -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
diff --git a/Hsbot/Irc/Plugin/Dummy.hs b/Hsbot/Irc/Plugin/Dummy.hs
new file mode 100644
index 0000000..48515ce
--- /dev/null
+++ b/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 ()
+
diff --git a/Hsbot/Irc/Plugin/Ping.hs b/Hsbot/Irc/Plugin/Ping.hs
new file mode 100644
index 0000000..6a38f0d
--- /dev/null
+++ b/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 ()
+
diff --git a/Plugins/Quote.hs b/Hsbot/Irc/Plugin/Quote.hs
index 61e4558..ff037c7 100644
--- a/Plugins/Quote.hs
+++ b/Hsbot/Irc/Plugin/Quote.hs
@@ -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)
-          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'
 
diff --git a/Hsbot/Irc/PluginCommons.hs b/Hsbot/Irc/PluginCommons.hs
new file mode 100644
index 0000000..71f00a4
--- /dev/null
+++ b/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
+