From 9dda7dc1b9aa3118a4b320185264b5e6079d041a Mon Sep 17 00:00:00 2001
From: Julien Dessaux
Date: Sat, 29 May 2010 22:38:18 +0200
Subject: Added signal handling and a better semantic for bot status.

---
 Hsbot/Core.hs    | 21 +++++++++++++++++----
 Hsbot/Message.hs | 15 +++++++++++----
 Hsbot/Types.hs   | 12 +++++++++++-
 3 files changed, 39 insertions(+), 9 deletions(-)

(limited to 'Hsbot')

diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs
index 025e0c5..b6c4d9c 100644
--- a/Hsbot/Core.hs
+++ b/Hsbot/Core.hs
@@ -10,6 +10,7 @@ import qualified Data.Map as M
 import Data.Time
 import Prelude hiding (catch)
 import System.IO()
+import System.Posix.Signals
 
 import Hsbot.Config
 import Hsbot.Message
@@ -23,6 +24,9 @@ hsbot config = do
     putStrLn "[Hsbot] Opening communication channel... "
     chan <- newChan :: IO (Chan BotMsg)
     mvar <- newMVar M.empty :: IO (MVar BotResumeData)
+    putStrLn "[Hsbot] Installing signal handlers... "
+    _ <- installHandler sigHUP (Catch $ sigHupHandler chan) Nothing
+    _ <- installHandler sigTERM (Catch $ sigTermHandler chan) Nothing
     putStrLn "[Hsbot] Spawning IrcBot plugins... "
     botState <- execStateT spawnPlugins BotState { botStartTime  = startTime
                                                  , botPlugins    = M.empty
@@ -40,7 +44,8 @@ hsbot config = do
   where
     runLoop :: BotState -> IO (BotStatus, BotState)
     runLoop botState = do
-        (status, botState') <- (runStateT botCore botState) `catch` (\(_ :: IOException) -> return (BotExit, botState))
+        (status, botState') <- (runStateT botCore botState) `catches` [ Handler (\ (_ :: IOException) -> return (BotExit, botState))
+                                                                      , Handler (\ (_ :: AsyncException) -> return (BotExit, botState)) ]
         case status of
             BotContinue -> runLoop botState'
             _           -> return (status, botState')
@@ -55,10 +60,10 @@ botCore = do
     chan <- gets botChan
     msg  <- liftIO $ readChan chan
     case msg of
-        InMsg  _      -> return BotContinue
-        OutMsg _      -> return BotContinue
-        IntMsg intMsg -> processInternalMessage $ IntMsg intMsg
+        IntMsg intMsg -> processInternalMessage intMsg
         UpdMsg updMsg -> processUpdateMessage updMsg
+        RebMsg rebMsg -> processRebootMessage rebMsg
+        ExiMsg exiMsg -> processExitMessage exiMsg
 
 -- | Process an update command
 processUpdateMessage :: ResumeMsg -> Bot (BotStatus)
@@ -69,3 +74,11 @@ processUpdateMessage msg = do
     liftIO $ modifyMVar_ resumeData (\oldData -> return $ M.insert from stuff oldData)
     return BotContinue
 
+-- | signals handlers
+sigHupHandler :: Chan BotMsg -> IO ()
+sigHupHandler chan = writeChan chan $ RebMsg RebootMsg { rebMsgFrom = "HUP handler" }
+
+-- | signals handlers
+sigTermHandler :: Chan BotMsg -> IO ()
+sigTermHandler chan = writeChan chan $ ExiMsg ExitMsg { exiMsgFrom = "TERM handler" }
+
diff --git a/Hsbot/Message.hs b/Hsbot/Message.hs
index f38438f..933394b 100644
--- a/Hsbot/Message.hs
+++ b/Hsbot/Message.hs
@@ -1,5 +1,7 @@
 module Hsbot.Message
     ( processInternalMessage
+    , processRebootMessage
+    , processExitMessage
     ) where
 
 import Control.Monad.State
@@ -9,16 +11,15 @@ import Hsbot.PluginUtils
 import Hsbot.Types
 
 -- | Processes an internal message
-processInternalMessage :: BotMsg -> Bot (BotStatus)
-processInternalMessage (IntMsg msg)
+processInternalMessage :: Msg -> Bot (BotStatus)
+processInternalMessage msg
   | msgTo msg == "CORE" = processCoreMessage msg
   | otherwise = do
       plugins <- gets botPlugins
       case M.lookup (msgTo msg) plugins of
-          Just (plugin, _) -> sendToPlugin (IntMsg msg) plugin
+          Just (plugin, _, _) -> sendToPlugin (IntMsg msg) plugin
           Nothing          -> return ()
       return BotContinue
-processInternalMessage _ = return BotContinue
 
 processCoreMessage :: Msg -> Bot (BotStatus)
 processCoreMessage msg = do
@@ -26,3 +27,9 @@ processCoreMessage msg = do
         "REBOOT" -> return BotReboot
         _        -> return BotContinue
 
+processRebootMessage :: RebootMsg -> Bot (BotStatus)
+processRebootMessage _ = return BotReboot   -- TODO : check who is sending that to us
+
+processExitMessage :: ExitMsg -> Bot (BotStatus)
+processExitMessage _ = return BotExit   -- TODO : check who is sending that to us
+
diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs
index 4052e58..009390d 100644
--- a/Hsbot/Types.hs
+++ b/Hsbot/Types.hs
@@ -4,9 +4,11 @@ module Hsbot.Types
     , BotResumeData
     , BotState (..)
     , BotStatus (..)
+    , ExitMsg (..)
     , Msg (..)
     , Plugin
     , PluginState (..)
+    , RebootMsg (..)
     , ResumeData
     , ResumeMsg (..)
     ) where
@@ -61,5 +63,13 @@ data ResumeMsg = ResMsg
     , resMsgData :: ResumeData
     } deriving (Show)
 
-data BotMsg = InMsg Msg | OutMsg Msg | IntMsg Msg | UpdMsg ResumeMsg deriving (Show)
+data RebootMsg = RebootMsg
+    { rebMsgFrom :: String
+    } deriving (Show)
+
+data ExitMsg = ExitMsg
+    { exiMsgFrom :: String
+    } deriving (Show)
+
+data BotMsg = IntMsg Msg | UpdMsg ResumeMsg | RebMsg RebootMsg | ExiMsg ExitMsg deriving (Show)
 
-- 
cgit v1.2.3