From c1662ba7b982a8502dc9f32031b7cb518df7f60e Mon Sep 17 00:00:00 2001
From: Julien Dessaux
Date: Sun, 16 May 2010 00:01:00 +0200
Subject: 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/Core.hs | 110 ++++++++++++++++++++++++++++------------------------------
 1 file changed, 54 insertions(+), 56 deletions(-)

(limited to 'Hsbot/Core.hs')

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