Changed the way I handled the Bot monad for more concurrency.

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
+    botNotInitialized <- asks envBotState >>= liftIO . isEmptyMVar
-                       , botHooks    = []
+    when botNotInitialized runFirstSteps
-                       , botChannels = []
+    trueRunHsbot
-                       , botNickname = [] }
-    evalStateT trueRunHsbot bot
   where
-    trueRunHsbot :: Bot (Env IO) BotStatus
+    -- | Initialize the dialog with the IRC server
-    trueRunHsbot = do
+    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
+        chan <- asks envChan
-        (liftIO . forkIO $ botReader connhdl tlsCtx chan myOwnThreadId) >>= lift . addThreadIdToQuitMVar
+        (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
+        (liftIO . forkIO $ runReaderT botLoop env) >>= addThreadIdToQuitMVar
-        finalStateMVar <- liftIO newEmptyMVar
-        (liftIO . forkIO $ runReaderT (execStateT botLoop bot >>= storeFinalState finalStateMVar) env) >>= lift . 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
+    chan <- asks envChan
-    hooks <- gets botHooks
     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

Hsbot/Plugin.hs

@@ -10,8 +10,13 @@ import System.Log.Logger
 
 import Hsbot.Types
 
-loadPlugin :: PluginId -> Bot (Env IO) ()
+loadPlugin :: PluginId -> Env IO ()
 loadPlugin pId = do
+    botMVar <- asks envBotState
+    (liftIO $ takeMVar botMVar) >>= execStateT effectivelyLoadPlugin >>= liftIO . putMVar botMVar
+  where
+    effectivelyLoadPlugin :: Bot (Env IO) ()
+    effectivelyLoadPlugin = do
         bot <- get
         chan <- liftIO (newChan :: IO (Chan Message))
         master <- lift $ asks envChan
@@ -21,7 +26,6 @@ loadPlugin pId = do
             pState = PluginState { pluginId     = pId
                                  , pluginChan   = chan
                                  , pluginMaster = master }
-    -- We check for unicity
         case M.lookup name oldPlugins of
             Just _  -> liftIO . warningM "Hsbot.Core.LoadPlugin" $ "Not loading already loaded plugin : " ++ name
             Nothing -> do
@@ -32,7 +36,6 @@ loadPlugin pId = do
                 let newPlugins = M.insert name (pState, finalStateMVar, threadId) oldPlugins
                 put $ bot { botPlugins = newPlugins
                           , botHooks   = chan : botHooks bot }
-  where
     storeFinalState :: MVar PluginState -> PluginState -> Env IO ()
     storeFinalState finalStateMVar finalState = liftIO $ putMVar finalStateMVar finalState
 

Hsbot/Types.hs

@@ -25,7 +25,8 @@ import System.IO
 type Env = ReaderT BotEnv
 
 data BotEnv = BotEnv
-    { envHandle      :: Handle
+    { envBotState    :: MVar BotState
+    , envHandle      :: Handle
     , envChan        :: Chan Message
     , envQuitMv      :: MVar BotStatus
     , envThreadIdsMv :: MVar [ThreadId]

hsbot.cabal

@@ -1,5 +1,5 @@
 Name:               hsbot
-Version:            0.4.4
+Version:            0.4.5
 Cabal-version:      >=1.2
 Synopsis:           A multipurposes IRC bot
 Description: