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

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

@@ -0,0 +1,73 @@
+module Hsbot.Irc.Message
+    ( IrcBotMsg (..)
+    , IrcCmd (..)
+    , IrcMsg (..)
+    , emptyIrcMsg
+    , parseIrcMsg
+    , serializeIrcMsg
+    ) where
+
+import Control.Monad.Identity
+import Text.Parsec
+
+-- | 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
+parseIrcMsg line = parse pMsg "" line
+
+pMsg :: ParsecT String u Identity IrcMsg
+pMsg = do
+    pfx <- optionMaybe pPrefix
+    cmd <- pCommand
+    params <- many (char ' ' >> (pLongParam <|> pShortParam))
+    _ <- char '\r'
+    --eof
+    return $ IrcMsg pfx cmd params
+
+pPrefix :: ParsecT String u Identity [Char]
+pPrefix = do
+    _ <- char ':'
+    pfx <- many1 (noneOf " ")
+    _ <- space
+    return pfx
+
+pCommand :: ParsecT String u Identity [Char]
+pCommand = count 3 digit <|> many1 upper
+
+pLongParam :: ParsecT String u Identity [Char]
+pLongParam = char ':' >> (many1 (noneOf "\r"))
+
+pShortParam :: ParsecT String u Identity [Char]
+pShortParam = many1 (noneOf " \r")
+
+-- | Serialize an IRC message to a string.
+serializeIrcMsg :: IrcMsg -> String
+serializeIrcMsg (IrcMsg pfx cmd params) = pfxStr ++ cmd ++ paramStr
+    where pfxStr = case pfx of
+                        Nothing  -> ""
+                        Just pfx' -> ":" ++ pfx' ++ " "
+          paramStr = concat (map paramToStr (init params)
+                             ++ [lastParamToStr (last params)])
+          paramToStr p = " " ++ p
+          lastParamToStr p = " :" ++ p
+

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

@@ -0,0 +1,63 @@
+module Hsbot.Irc.Plugin.Core
+    ( ircBotPluginCore
+    ) where
+
+import Control.Concurrent (Chan, myThreadId)
+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
+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'
+
+-- | The IrcPlugin monad main function
+run :: IrcPlugin ()
+run = forever $ do
+    msg <- readMsg
+    eval msg
+  where
+    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
+                            _        -> return () -- TODO : help message
+            "ANSWER" -> let stuff = ircCmdMsg intCmd
+                        in answerMsg request ("Loaded plugins : " ++ stuff)
+            _        -> return ()
+    eval _ = return ()
+
+-- | The list command
+listPlugins :: IrcMsg -> IrcPlugin ()
+listPlugins request = do
+    sendCommandWithRequest "LIST" "CORE" (unwords []) request
+
+-- | The load command
+loadPlugin :: [String] -> IrcPlugin ()
+loadPlugin pluginNames = mapM_ (sendCommand "LOAD" "CORE") pluginNames
+
+-- | The reload command
+reloadPlugin :: [String] -> IrcPlugin ()
+reloadPlugin pluginNames = mapM_ (sendCommand "RELOAD" "CORE") pluginNames
+
+-- | The unload command
+unloadPlugin :: [String] -> IrcPlugin ()
+unloadPlugin pluginNames = mapM_ (sendCommand "UNLOAD" "CORE") pluginNames
+

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

@@ -0,0 +1,177 @@
+module Hsbot.Irc.Plugin.Quote
+    ( ircBotPluginQuote
+    ) where
+
+import Control.Concurrent (myThreadId)
+import Control.Concurrent.Chan
+import Control.Exception
+import Control.Monad.State
+import qualified Data.Map as M
+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.Irc.Message
+import Hsbot.Irc.PluginCommons
+
+-- | A quote element
+data QuoteElt = QuoteElt
+    { eltQuoter :: String
+    , eltQuote  :: String
+    } deriving (Read, Show)
+
+-- | A quote object
+data Quote = Quote
+    { quoter    :: String
+    , quote     :: [QuoteElt]
+    , quoteTime :: UTCTime
+    , votes     :: Int
+    } deriving (Read, Show)
+
+-- | A QuoteBot state
+data QuoteBotState = QuoteBotState
+    { nextQuoteId      :: Integer
+    , quoteBotDB       :: M.Map Integer Quote
+    , quotesInProgress :: M.Map Integer Quote
+    } deriving (Read, Show)
+
+-- | The QuoteBot monad
+type QuoteBot a = StateT QuoteBotState (StateT IrcPluginState IO) a
+
+-- | The plugin's main entry point
+ircBotPluginQuote :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
+ircBotPluginQuote myChan masterChan = do
+    -- First of all we restore the database
+    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
+    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
+
+-- | The IrcPlugin monad main function
+run :: QuoteBotState -> IrcPlugin (QuoteBotState)
+run quoteBot = do
+    msg <- readMsg
+    quoteBot' <- eval msg
+    run quoteBot'
+  where
+    -- | evaluate what we just received
+    eval :: IrcBotMsg -> IrcPlugin (QuoteBotState)
+    eval (IntIrcCmd intCmd)
+      | ircCmdCmd intCmd == "RUN" = do
+          quoteBot' <- execStateT (runCommand intCmd) quoteBot
+          return quoteBot'
+      | otherwise = return quoteBot
+    eval (InIrcMsg _) = return (quoteBot)
+    eval (OutIrcMsg _) = return (quoteBot)
+
+-- | run a command we received
+runCommand :: IrcCmd -> QuoteBot ()
+runCommand intCmd
+  | theCommand == "quote" = runQuoteCommand
+  | otherwise = return ()
+  where
+    -- | the message is a quote command
+    runQuoteCommand :: QuoteBot ()
+      | length args == 0 = do
+          quoteDB <- gets quoteBotDB
+          x <- liftIO $ randomRIO (0, (length $ M.keys quoteDB) - 1)
+          if (length $ M.keys quoteDB) > 0
+            then
+              mapM_ (lift . answerMsg request) (formatQuote (M.keys quoteDB !! x) (M.elems quoteDB !! x))
+            else
+              lift $ answerMsg request "The quote database is empty."
+      | otherwise = do
+          dispatchQuoteCmd $ head args
+    -- | quote command dispatcher
+    dispatchQuoteCmd :: String -> QuoteBot ()
+    dispatchQuoteCmd cmd
+      | cmd == "start"  = do
+          quoteBot <- get
+          now <- liftIO $ getCurrentTime
+          let sender   = takeWhile (/= '!') $ fromMaybe "ARGH" (ircMsgPrefix request)
+              newQuote = Quote sender [(quoteElt stuff)] now 0
+              quoteId     = nextQuoteId quoteBot
+              quotesInProgress' = M.insert quoteId  newQuote (quotesInProgress quoteBot)
+          put $ quoteBot { nextQuoteId = quoteId + 1, quotesInProgress = quotesInProgress' }
+          lift $ answerMsg request ("New quoteId : " ++ show quoteId)
+          syncQuoteBot
+      | cmd == "append" = do
+          quoteBot <- get
+          case reads (head stuff) of
+              [(quoteId :: Integer,"")] -> do
+                  case M.lookup quoteId (quotesInProgress quoteBot) of
+                      Just theQuote -> do
+                          let newQuote = theQuote { quote = (quoteElt $ tail stuff) : (quote theQuote) }
+                              quotesInProgress'  = M.insert quoteId newQuote (quotesInProgress quoteBot)
+                          put $ quoteBot { quotesInProgress = quotesInProgress' }
+                          syncQuoteBot
+                      Nothing       -> lift $ answerMsg request ("quoteId not found : " ++ (show quoteId))
+              _ -> lift $ answerMsg request ("Invalid quoteId : " ++ (head stuff))
+      | cmd == "commit" = do
+          quoteBot <- get
+          case reads (head stuff) of
+              [(quoteId :: Integer,"")] -> do
+                  case M.lookup quoteId (quotesInProgress quoteBot) of
+                      Just theQuote -> do
+                          let quoteBotDB'       = M.insert quoteId theQuote (quoteBotDB quoteBot)
+                              quotesInProgress' = M.delete quoteId (quotesInProgress quoteBot)
+                          put $ quoteBot { quoteBotDB = quoteBotDB', quotesInProgress = quotesInProgress' }
+                          syncQuoteBot
+                      Nothing       -> lift $ answerMsg request ("quoteId not found : " ++ (show quoteId))
+              _ -> lift $ answerMsg request ("Invalid quoteId : " ++ (head stuff))
+      -- | cmd == "abort"  = 
+      | otherwise = lift $ answerMsg request ("Invalid command : " ++ cmd)
+    -- | Gets the new QuoteElt
+    quoteElt :: [String] -> QuoteElt
+    quoteElt msg = do
+        let budy   = head $ msg
+            theQuote  = unwords . tail $ msg
+        QuoteElt budy theQuote
+    -- | utilities
+    params  = words . ircCmdMsg $ intCmd
+    theCommand = head params
+    args    = tail params
+    stuff   = tail args
+    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
+    liftIO . hPutStr file' $ show quoteBot
+    liftIO $ hClose file'
+
+formatQuote :: Integer -> Quote -> [String]
+formatQuote quoteId theQuote =
+    ("+---| " ++ (show quoteId) ++ " |-- Reported by " ++ (quoter theQuote) ++ " on " ++ (show $ quoteTime theQuote)) :
+    foldl (\acc x -> formatQuoteElt x : acc) ["`------------------------------------------"] (quote theQuote)
+  where
+    formatQuoteElt :: QuoteElt -> String
+    formatQuoteElt quoteElt = "| <" ++ (eltQuoter quoteElt) ++ "> " ++ (eltQuote quoteElt)
+

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