diff options
Diffstat (limited to '')
| -rw-r--r-- | Hsbot.hs | 30 | ||||
| -rw-r--r-- | Hsbot/Core.hs | 35 | ||||
| -rw-r--r-- | Hsbot/Plugin/Admin.hs | 4 | ||||
| -rw-r--r-- | Hsbot/Types.hs | 2 | ||||
| -rw-r--r-- | Hsbot/Utils.hs | 15 |
5 files changed, 59 insertions, 27 deletions
@@ -5,13 +5,19 @@ module Hsbot import qualified Config.Dyre as Dyre import Config.Dyre.Relaunch import Control.Monad.Reader +import qualified Data.Map as M import System.Log.Logger +import qualified Network.IRC as IRC import Hsbot.Core import Hsbot.Types +import Hsbot.Utils + +data State = State (M.Map String String) deriving (Read, Show) startHsbot :: Config -> IO () startHsbot config = do + (State buffer) <- restoreTextState $ State M.empty -- checking for configuration file compilation error case configErrors config of Nothing -> return () @@ -19,16 +25,34 @@ startHsbot config = do -- initialization infoM "Hsbot" "Bot initializations" hsbotEnv <- initHsbot config + -- Handle previous exit state if it exists + die_msgs <- case M.lookup "die_msg" buffer of + Just dieMsg -> case reads dieMsg :: [(BotStatus, String)] of + (status, _):_ -> case status of + BotReload reason -> return ["hsbot reloaded, reason : " ++ reason] + BotRestart (reason, Just info) -> return ["hsbot restarted, readon : " ++ reason, "additional information: " ++ info] + BotRestart (reason, Nothing) -> return ["hsbot restarted, readon : " ++ reason] + BotExit -> return [] + _ -> return ["hsbot die_msg parsing error, this should not happen"] + Nothing -> return [] + let connhdl = envHandle hsbotEnv + tlsCtx = envTLSCtx hsbotEnv + channels = configChannels config + mapM_ (infoM "Hsbot") die_msgs + mapM_ (\msg -> mapM_ (\channel -> sendStr hsbotEnv connhdl tlsCtx . IRC.encode $ IRC.Message Nothing "PRIVMSG" [channel, msg]) channels) die_msgs -- main stuff infoM "Hsbot" "Bot core starting" status <- runReaderT runHsbot hsbotEnv infoM "Hsbot" $ "Bot core exited with status " ++ show status -- Handling exit signal case status of - BotContinue -> startHsbot config -- TODO do something not so dumb about starting over BotExit -> runReaderT terminateHsbot hsbotEnv - BotReload -> relaunchMaster Nothing -- TODO relaunchWithTextState (state { stateConfig = config }) Nothing, add a flag that prevent spawning the sockets again - BotRestart -> relaunchMaster Nothing -- TODO relaunch and kill sockets + BotReload reason -> do + runReaderT terminateHsbot hsbotEnv + relaunchWithTextState (M.singleton "die_msg" . show $ BotReload reason) Nothing -- TODO find a way to properly implement that, then insert necessary information in this MVar + BotRestart reason -> do + runReaderT terminateHsbot hsbotEnv + relaunchWithTextState (M.singleton "die_msg" . show $ BotRestart reason) Nothing hsbot :: Config -> IO () hsbot = Dyre.wrapMain $ Dyre.defaultParams diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs index eacbe63..49f5f5d 100644 --- a/Hsbot/Core.hs +++ b/Hsbot/Core.hs @@ -70,10 +70,10 @@ runHsbot = do config = envConfig env nickname = head $ configNicknames config channels = configChannels config - liftIO . sendStr connhdl tlsCtx . IRC.encode $ IRC.nick nickname - liftIO . sendStr connhdl tlsCtx . IRC.encode $ IRC.user nickname hostname "*" (configRealname config) + liftIO . sendStr env connhdl tlsCtx . IRC.encode $ IRC.nick nickname + liftIO . sendStr env connhdl tlsCtx . IRC.encode $ IRC.user nickname hostname "*" (configRealname config) -- Then we join channels - mapM_ (liftIO . sendStr connhdl tlsCtx . IRC.encode . IRC.joinChan) channels + mapM_ (liftIO . sendStr env connhdl tlsCtx . IRC.encode . IRC.joinChan) channels -- Finally we set the new bot state asks envBotState >>= liftIO . flip putMVar BotState { botPlugins = M.empty , botAccess = configAccess config @@ -88,9 +88,8 @@ runHsbot = do liftIO $ debugM "Hsbot.Core" "Spawning reader thread" let connhdl = envHandle env tlsCtx = envTLSCtx env - myOwnThreadId <- liftIO myThreadId chan <- asks envChan - (liftIO . forkIO $ botReader connhdl tlsCtx chan myOwnThreadId) >>= addThreadIdToQuitMVar + (liftIO . forkIO $ botReader env connhdl tlsCtx chan) >>= addThreadIdToQuitMVar -- Then we spawn all plugins asks envConfig >>= mapM_ loadPlugin . configPlugins -- Finally we spawn the main bot loop @@ -102,18 +101,18 @@ runHsbot = do -- TODO : kill plugin threads return code -botReader :: Handle -> Maybe TLSCtx -> Chan Message -> ThreadId -> IO () -botReader _ (Just ctx) chan _ = forever $ - fmap L.toString (recvData ctx) >>= handleIncomingStr chan -- TODO exceptions -botReader handle Nothing chan fatherThreadId = forever $ - hGetLine handle `catch` handleIOException >>= handleIncomingStr chan - where - handleIOException :: IOException -> IO String - handleIOException ioException = do - throwTo fatherThreadId ioException - myId <- myThreadId - killThread myId - return "" +botReader :: BotEnv -> Handle -> Maybe TLSCtx -> Chan Message -> IO () +botReader env _ (Just ctx) chan = forever $ + fmap L.toString (recvData ctx) `catch` handleIOException env "botReader died" >>= handleIncomingStr chan +botReader env handle Nothing chan = forever $ + hGetLine handle `catch` handleIOException env "botReader died" >>= handleIncomingStr chan + +handleIOException :: BotEnv -> String -> IOException -> IO String +handleIOException env msg ioException = do + runReaderT (setGlobalQuitMVar $ BotRestart (show ioException, Just msg)) env + myId <- myThreadId + killThread myId + return "" handleIncomingStr :: Chan Message -> String -> IO () handleIncomingStr chan str = @@ -136,7 +135,7 @@ botLoop = forever $ do let connhdl = envHandle env tlsCtx = envTLSCtx env liftIO $ debugM "Hsbot.Loop" $ "--> " ++ show outMsg - liftIO . sendStr connhdl tlsCtx $ IRC.encode outMsg + liftIO . sendStr env connhdl tlsCtx $ IRC.encode outMsg terminateHsbot :: Env IO () terminateHsbot = do diff --git a/Hsbot/Plugin/Admin.hs b/Hsbot/Plugin/Admin.hs index 7dba362..cbec152 100644 --- a/Hsbot/Plugin/Admin.hs +++ b/Hsbot/Plugin/Admin.hs @@ -33,11 +33,11 @@ theAdmin = forever $ readMsg >>= eval else answerMsg msg "Only admins can do that." "restart":"help":_ -> answerMsg msg "restart hsbot, reset the running state to config file directives." "restart":_ -> lift (hasAccess (IRC.msg_prefix msg) Admin) >>= \right -> if right - then lift $ setGlobalQuitMVar BotRestart + then lift . setGlobalQuitMVar $ BotRestart (getSender msg ++ " request", Nothing) else answerMsg msg "Only admins can do that." "reload":"help":_ -> answerMsg msg "reload hsbot, and try merge the new config file directives with actual running state)." "reload":_ -> lift (hasAccess (IRC.msg_prefix msg) Admin) >>= \right -> if right - then lift $ setGlobalQuitMVar BotReload + then lift . setGlobalQuitMVar . BotReload $ getSender msg ++ " request" else answerMsg msg "Only admins can do that." _ -> return () | otherwise = return () diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs index 8f84482..7ca9ee0 100644 --- a/Hsbot/Types.hs +++ b/Hsbot/Types.hs @@ -66,7 +66,7 @@ data PluginId = PluginId data Message = IncomingMsg IRC.Message | OutgoingMsg IRC.Message -data BotStatus = BotContinue | BotExit | BotReload | BotRestart deriving (Show) +data BotStatus = BotExit | BotReload String | BotRestart (String, Maybe String) deriving (Read, Show) -- Config data Config = Config diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs index 2a8f58c..043037d 100644 --- a/Hsbot/Utils.hs +++ b/Hsbot/Utils.hs @@ -8,12 +8,14 @@ module Hsbot.Utils ) where import Control.Concurrent +import Control.Exception (IOException, catch) import Control.Monad.Reader import Control.Monad.State import qualified Data.ByteString.Lazy.UTF8 as L import qualified Data.List as L import qualified Network.IRC as IRC import Network.TLS +import Prelude hiding (catch) import System.IO import Hsbot.Types @@ -47,9 +49,16 @@ hasAccess (Just mask) right = do | otherwise = False -- Helpers -sendStr :: Handle -> Maybe TLSCtx -> String -> IO () -sendStr _ (Just ctx) msg = sendData ctx . L.fromString $ msg ++ "\r\n" -sendStr handle Nothing msg = hPutStrLn handle $ msg ++ "\r\n" +sendStr :: BotEnv -> Handle -> Maybe TLSCtx -> String -> IO () +sendStr env _ (Just ctx) msg = sendData ctx (L.fromString $ msg ++ "\r\n") `catch` handleIOException env ("sendStr " ++ msg) +sendStr env handle Nothing msg = hPutStrLn handle (msg ++ "\r\n") `catch` handleIOException env ("sendStr " ++ msg) + +handleIOException :: BotEnv -> String -> IOException -> IO () +handleIOException env msg ioException = do + runReaderT (setGlobalQuitMVar $ BotRestart (show ioException, Just msg)) env + myId <- myThreadId + killThread myId + return () -- TLS utils initTLSEnv :: TLSConfig -> IO TLSParams |