From 5d2c3cdeb27f7850b6fc3fd995978b97985222b9 Mon Sep 17 00:00:00 2001
From: Julien Dessaux
Date: Sun, 1 May 2011 16:02:33 +0200
Subject: Changed the way I handled the Bot monad for more concurrency.

---
 Hsbot/Core.hs | 52 ++++++++++++++++++++++++++++++----------------------
 1 file changed, 30 insertions(+), 22 deletions(-)

(limited to 'Hsbot/Core.hs')

diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs
index 529e6cb..f1659e9 100644
--- a/Hsbot/Core.hs
+++ b/Hsbot/Core.hs
@@ -7,7 +7,6 @@ module Hsbot.Core
 import Control.Concurrent
 import Control.Exception (IOException, catch)
 import Control.Monad.Reader
-import Control.Monad.State
 import qualified Data.ByteString.Char8 as C
 import qualified Data.ByteString.Lazy as L
 import qualified Data.Map as M
@@ -26,6 +25,7 @@ import Hsbot.Utils
 initHsbot :: Config -> IO BotEnv
 initHsbot config = do
     chan <- newChan :: IO (Chan Message)
+    botState <- newEmptyMVar
     threadIdsMv <- newMVar []
     quitMv <- newEmptyMVar
     let hostname = configAddress config
@@ -43,7 +43,8 @@ initHsbot config = do
             handshake sCtx
             return (Just tlsenv, Just sCtx))
         else return (Nothing, Nothing)
-    return BotEnv { envHandle      = connhdl
+    return BotEnv { envBotState    = botState
+                  , envHandle      = connhdl
                   , envChan        = chan
                   , envQuitMv      = quitMv
                   , envThreadIdsMv = threadIdsMv
@@ -53,16 +54,15 @@ initHsbot config = do
 
 runHsbot :: Env IO BotStatus
 runHsbot = do
-    let bot = BotState { botPlugins  = M.empty
-                       , botHooks    = []
-                       , botChannels = []
-                       , botNickname = [] }
-    evalStateT trueRunHsbot bot
+    botNotInitialized <- asks envBotState >>= liftIO . isEmptyMVar
+    when botNotInitialized runFirstSteps
+    trueRunHsbot
   where
-    trueRunHsbot :: Bot (Env IO) BotStatus
-    trueRunHsbot = do
+    -- | Initialize the dialog with the IRC server
+    runFirstSteps :: Env IO ()
+    runFirstSteps = do
+        env <- ask
         -- First we say hello
-        env <- lift ask
         hostname <- liftIO getHostName
         let connhdl  = envHandle env
             tlsCtx   = envTLSCtx env
@@ -71,26 +71,34 @@ runHsbot = do
             channels = configChannels config
         liftIO . sendStr connhdl tlsCtx . IRC.encode $ IRC.nick nickname
         liftIO . sendStr connhdl tlsCtx . IRC.encode $ IRC.user nickname hostname "*" (configRealname config)
+        -- Then we join channels
         mapM_ (liftIO . sendStr connhdl tlsCtx . IRC.encode . IRC.joinChan) channels
+        -- Finally we set the new bot state
+        asks envBotState >>= liftIO . (flip putMVar BotState { botPlugins  = M.empty
+                                                             , botHooks    = []
+                                                             , botChannels = channels
+                                                             , botNickname = nickname })
+    -- | Run the bot itself
+    trueRunHsbot :: Env IO BotStatus
+    trueRunHsbot = do
+        env <- ask
         -- Next we spawn the reader thread
         liftIO $ debugM "Hsbot.Core" "Spawning reader thread"
+        let connhdl  = envHandle env
+            tlsCtx   = envTLSCtx env
         myOwnThreadId  <- liftIO myThreadId
-        chan <- lift $ asks envChan
-        (liftIO . forkIO $ botReader connhdl tlsCtx chan myOwnThreadId) >>= lift . addThreadIdToQuitMVar
+        chan <- asks envChan
+        (liftIO . forkIO $ botReader connhdl tlsCtx chan myOwnThreadId) >>= addThreadIdToQuitMVar
         -- Then we spawn all plugins
-        lift (asks envConfig) >>= mapM_ loadPlugin . configPlugins
+        asks envConfig >>= mapM_ loadPlugin . configPlugins
         -- Finally we spawn the main bot loop
-        bot <- get
-        finalStateMVar <- liftIO newEmptyMVar
-        (liftIO . forkIO $ runReaderT (execStateT botLoop bot >>= storeFinalState finalStateMVar) env) >>= lift . addThreadIdToQuitMVar
+        (liftIO . forkIO $ runReaderT botLoop env) >>= addThreadIdToQuitMVar
         -- We wait for the quit signal
         code <- asks envQuitMv >>= liftIO . takeMVar
         -- and we clean things up
         asks envThreadIdsMv >>= liftIO . readMVar >>= liftIO . mapM_ killThread
         -- TODO : kill plugin threads
         return code
-    storeFinalState :: MVar BotState -> BotState -> Env IO ()
-    storeFinalState finalStateMVar finalState = liftIO $ putMVar finalStateMVar finalState
 
 botReader :: Handle -> Maybe TLSCtx -> Chan Message -> ThreadId -> IO ()
 botReader _ (Just ctx) chan _ = forever $
@@ -113,16 +121,16 @@ handleIncomingStr chan str =
             writeChan chan $ IncomingMsg msg
         Nothing -> debugM "Ircd.Reader" $ "Error: couldn't decode : " ++ str     -- TODO: spam control
 
-botLoop :: Bot (Env IO) ()
+botLoop :: Env IO ()
 botLoop = forever $ do
-    chan <- lift $ asks envChan
-    hooks <- gets botHooks
+    chan <- asks envChan
     msg  <- liftIO $ readChan chan
+    hooks <- asks envBotState >>= liftIO . flip withMVar (return . botHooks)
     mapM_ (liftIO . flip writeChan msg) hooks
     case msg of
         IncomingMsg _ -> return () -- TODO parse for core commands
         OutgoingMsg outMsg -> do
-            env <- lift ask
+            env <- ask
             let connhdl  = envHandle env
                 tlsCtx   = envTLSCtx env
             liftIO $ debugM "Ircd.Reader" $ "--> " ++ show outMsg
-- 
cgit v1.2.3