From 34bac20fa59e8c258b6fe58e93c8ea85065f45ac Mon Sep 17 00:00:00 2001 From: Abhinav Sarkar Date: Mon, 12 May 2014 02:29:26 +0530 Subject: [PATCH] Hid message handler states from client. Much cleaner code. --- Network/IRC/Client.hs | 80 +++++++++++---------------- Network/IRC/Handlers.hs | 19 ++++--- Network/IRC/Handlers/MessageLogger.hs | 63 ++++++++++----------- Network/IRC/Handlers/SongSearch.hs | 8 +-- Network/IRC/Types.hs | 61 ++++++++------------ 5 files changed, 102 insertions(+), 129 deletions(-) diff --git a/Network/IRC/Client.hs b/Network/IRC/Client.hs index 6ad7266..6007f67 100644 --- a/Network/IRC/Client.hs +++ b/Network/IRC/Client.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards, ScopedTypeVariables, NoImplicitPrelude, OverloadedStrings, BangPatterns #-} +{-# LANGUAGE RecordWildCards, ScopedTypeVariables, NoImplicitPrelude, OverloadedStrings #-} module Network.IRC.Client (run) where @@ -9,7 +9,6 @@ import ClassyPrelude import Control.Concurrent.Lifted import Control.Monad.Reader hiding (forM_, foldM) import Control.Monad.State hiding (forM_, foldM) -import Data.Maybe (fromJust) import Network import System.IO (hSetBuffering, BufferMode(..)) import System.Timeout @@ -39,29 +38,29 @@ listenerLoop idleFor = do bot@Bot { .. } <- ask let nick = botNick botConfig - nStatus <- liftIO $ do + nStatus <- liftIO $ if idleFor >= (oneSec * botTimeout botConfig) then return Disconnected - else do - when (status == Kicked) $ - threadDelay (5 * oneSec) >> sendCommand bot JoinCmd + else do + when (status == Kicked) $ + threadDelay (5 * oneSec) >> sendCommand bot JoinCmd - mLine <- map (map initEx) . timeout oneSec . hGetLine $ socket - case mLine of - Nothing -> dispatchHandlers bot IdleMsg >> return Idle - Just line -> do - now <- getCurrentTime - debug $ "< " ++ line + mLine <- map (map initEx) . timeout oneSec . hGetLine $ socket + case mLine of + Nothing -> dispatchHandlers bot IdleMsg >> return Idle + Just line -> do + now <- getCurrentTime + debug $ "< " ++ line - let message = msgFromLine botConfig now line - nStatus <- case message of - JoinMsg { .. } | userNick user == nick -> debug "Joined" >> return Joined - KickMsg { .. } | kickedNick == nick -> debug "Kicked" >> return Kicked - ModeMsg { user = Self, .. } -> sendCommand bot JoinCmd >> return Connected - _ -> return Connected + let message = msgFromLine botConfig now line + nStatus <- case message of + JoinMsg { .. } | userNick user == nick -> debug "Joined" >> return Joined + KickMsg { .. } | kickedNick == nick -> debug "Kicked" >> return Kicked + ModeMsg { user = Self, .. } -> sendCommand bot JoinCmd >> return Connected + _ -> return Connected - dispatchHandlers bot message - return nStatus + dispatchHandlers bot message + return nStatus put nStatus case nStatus of @@ -71,49 +70,36 @@ listenerLoop idleFor = do where dispatchHandlers bot@Bot { .. } message = - forM_ (msgHandlers botConfig) $ \msgHandlerName -> fork $ + forM_ (mapToList msgHandlers) $ \(_, msgHandler) -> fork $ handle (\(e :: SomeException) -> debug $ "Exception! " ++ pack (show e)) $ do - let mMsgHandler = getMsgHandler msgHandlerName - case mMsgHandler of - Nothing -> debug $ "No msg handler found with name: " ++ msgHandlerName - Just msgHandler -> - let msgHandlerState = fromJust . lookup msgHandlerName $ msgHandlerStates - in modifyMVar_ msgHandlerState $ \hState -> do - !(mCmd, nhState) <- runMsgHandler msgHandler botConfig hState message - case mCmd of - Nothing -> return () - Just cmd -> sendCommand bot cmd - return nhState + mCmd <- runMsgHandler msgHandler botConfig message + case mCmd of + Nothing -> return () + Just cmd -> sendCommand bot cmd -loadMsgHandlers :: BotConfig -> IO MsgHandlerStates +loadMsgHandlers :: BotConfig -> IO (Map MsgHandlerName MsgHandler) loadMsgHandlers botConfig@BotConfig { .. } = - flip (`foldM` mapFromList []) msgHandlers $ \hMap msgHandlerName -> do + flip (`foldM` mempty) msgHandlerNames $ \hMap msgHandlerName -> do debug $ "Loading msg handler: " ++ msgHandlerName - let mMsgHandler = getMsgHandler msgHandlerName + mMsgHandler <- mkMsgHandler botConfig msgHandlerName case mMsgHandler of Nothing -> debug ("No msg handler found with name: " ++ msgHandlerName) >> return hMap - Just msgHandler -> do - !msgHandlerState <- initMsgHandler msgHandler botConfig - mvMsgHandlerState <- newMVar msgHandlerState - return $ insertMap msgHandlerName mvMsgHandlerState hMap + Just msgHandler -> return $ insertMap msgHandlerName msgHandler hMap unloadMsgHandlers :: Bot -> IO () unloadMsgHandlers Bot { .. } = - forM_ (mapToList msgHandlerStates) $ \(msgHandlerName, msgHandlerState) -> do + forM_ (mapToList msgHandlers) $ \(msgHandlerName, msgHandler) -> do debug $ "Unloading msg handler: " ++ msgHandlerName - let mMsgHandler = getMsgHandler msgHandlerName - case mMsgHandler of - Nothing -> debug ("No msg handler found with name: " ++ msgHandlerName) - Just msgHandler -> takeMVar msgHandlerState >>= exitMsgHandler msgHandler botConfig + stopMsgHandler msgHandler botConfig connect :: BotConfig -> IO Bot connect botConfig@BotConfig { .. } = do debug "Connecting ..." socket <- connectToWithRetry hSetBuffering socket LineBuffering - msgHandlerStates <- loadMsgHandlers botConfig + msgHandlers <- loadMsgHandlers botConfig debug "Connected" - return $ Bot botConfig socket msgHandlerStates + return $ Bot botConfig socket msgHandlers where connectToWithRetry = connectTo (unpack server) (PortNumber (fromIntegral port)) `catch` (\(e :: SomeException) -> do @@ -130,7 +116,7 @@ disconnect bot@Bot { .. } = do addCoreMsgHandlers :: BotConfig -> BotConfig addCoreMsgHandlers botConfig = - botConfig { msgHandlers = hashNub $ msgHandlers botConfig ++ coreMsgHandlerNames } + botConfig { msgHandlerNames = hashNub $ msgHandlerNames botConfig ++ coreMsgHandlerNames } run :: BotConfig -> IO () run botConfig' = withSocketsDo $ do diff --git a/Network/IRC/Handlers.hs b/Network/IRC/Handlers.hs index b011a4a..a2eeda0 100644 --- a/Network/IRC/Handlers.hs +++ b/Network/IRC/Handlers.hs @@ -1,12 +1,12 @@ {-# LANGUAGE RecordWildCards, OverloadedStrings, NoImplicitPrelude, FlexibleContexts #-} -module Network.IRC.Handlers (coreMsgHandlerNames, getMsgHandler) where +module Network.IRC.Handlers (coreMsgHandlerNames, mkMsgHandler) where import qualified Network.IRC.Handlers.MessageLogger as L import qualified Network.IRC.Handlers.SongSearch as SS import ClassyPrelude -import Control.Monad.Reader +import Control.Monad.Reader.Class import Data.Text (strip) import Network.IRC.Types @@ -17,12 +17,15 @@ clean = toLower . strip coreMsgHandlerNames :: [Text] coreMsgHandlerNames = ["pingpong", "messagelogger"] -getMsgHandler :: MsgHandlerName -> Maybe MsgHandler -getMsgHandler "greeter" = Just $ newMsgHandler { msgHandlerRun = greeter } -getMsgHandler "welcomer" = Just $ newMsgHandler { msgHandlerRun = welcomer } -getMsgHandler "pingpong" = Just $ newMsgHandler { msgHandlerRun = pingPong } -getMsgHandler name = listToMaybe $ mapMaybe (\f -> f name) - [L.getMsgHandler, SS.getMsgHandler] +mkMsgHandler :: BotConfig -> MsgHandlerName -> IO (Maybe MsgHandler) +mkMsgHandler _ "greeter" = return . Just $ newMsgHandler { msgHandlerRun = greeter } +mkMsgHandler _ "welcomer" = return . Just $ newMsgHandler { msgHandlerRun = welcomer } +mkMsgHandler _ "pingpong" = return . Just $ newMsgHandler { msgHandlerRun = pingPong } +mkMsgHandler botConfig name = + flip (`foldM` Nothing) [L.mkMsgHandler, SS.mkMsgHandler] $ \acc h -> + case acc of + Just _ -> return acc + Nothing -> h botConfig name pingPong :: MonadMsgHandler m => Message -> m (Maybe Command) pingPong Ping { .. } = return . Just $ Pong msg diff --git a/Network/IRC/Handlers/MessageLogger.hs b/Network/IRC/Handlers/MessageLogger.hs index 7bdbebe..c842288 100644 --- a/Network/IRC/Handlers/MessageLogger.hs +++ b/Network/IRC/Handlers/MessageLogger.hs @@ -1,6 +1,6 @@ {-# LANGUAGE RecordWildCards, NoImplicitPrelude, OverloadedStrings, FlexibleContexts, ScopedTypeVariables #-} -module Network.IRC.Handlers.MessageLogger (getMsgHandler) where +module Network.IRC.Handlers.MessageLogger (mkMsgHandler) where import qualified Data.Configurator as C import qualified Data.Text.Format as TF @@ -8,8 +8,6 @@ import qualified Data.Text.Format.Params as TF import ClassyPrelude hiding (try, (), (<.>), FilePath) import Control.Monad.Reader -import Control.Monad.State -import Data.Dynamic import Data.Time (diffDays) import System.Directory import System.FilePath @@ -17,11 +15,15 @@ import System.IO (openFile, IOMode(..), hSetBuffering, BufferMode(..)) import Network.IRC.Types -getMsgHandler :: MsgHandlerName -> Maybe MsgHandler -getMsgHandler "messagelogger" = Just $ newMsgHandler { msgHandlerInit = initMessageLogger - , msgHandlerRun = messageLogger - , msgHandlerExit = exitMessageLogger } -getMsgHandler _ = Nothing +type LoggerState = Maybe (Handle, Day) + +mkMsgHandler :: BotConfig -> MsgHandlerName -> IO (Maybe MsgHandler) +mkMsgHandler botConfig "messagelogger" = do + state <- liftIO $ newIORef Nothing + initMessageLogger botConfig state + return . Just $ newMsgHandler { msgHandlerRun = flip messageLogger state + , msgHandlerStop = exitMessageLogger state } +mkMsgHandler _ _ = return Nothing getLogFilePath :: BotConfig -> IO FilePath getLogFilePath BotConfig { .. } = do @@ -35,33 +37,29 @@ openLogFile logFilePath = do hSetBuffering logFileHandle LineBuffering return logFileHandle -initMessageLogger :: MonadMsgHandler m => m () -initMessageLogger = do - botConfig <- ask - (logFileHandle, curDay) <- liftIO $ do - logFilePath <- getLogFilePath botConfig - logFileHandle <- openLogFile logFilePath - time <- getModificationTime logFilePath - return (logFileHandle, utctDay time) - put $ toDyn (logFileHandle, curDay) +initMessageLogger :: BotConfig -> IORef LoggerState -> IO () +initMessageLogger botConfig state = do + logFilePath <- getLogFilePath botConfig + logFileHandle <- openLogFile logFilePath + time <- getModificationTime logFilePath + atomicWriteIORef state $ Just (logFileHandle, utctDay time) -exitMessageLogger :: MonadMsgHandler m => m () -exitMessageLogger = do - mHandle <- map fromDynamic get +exitMessageLogger :: MonadMsgHandler m => IORef LoggerState -> m () +exitMessageLogger state = liftIO $ do + mHandle <- readIORef state case mHandle of - Nothing -> return () - Just (logFileHandle, _ :: UTCTime) -> liftIO $ hClose logFileHandle + Nothing -> return () + Just (logFileHandle, _ :: Day) -> hClose logFileHandle -withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> m (Maybe Command) -withLogFile action = do +withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m (Maybe Command) +withLogFile action state = do botConfig <- ask - (logFileHandle, prevDay) <- map (`fromDyn` error "No log file set") get - - (logFileHandle', curDay) <- liftIO $ do + liftIO $ do + Just (logFileHandle, prevDay) <- readIORef state curDay <- map utctDay getCurrentTime let diff = diffDays curDay prevDay - logFileHandle'' <- if diff >= 1 + logFileHandle' <- if diff >= 1 then do hClose logFileHandle logFilePath <- getLogFilePath botConfig @@ -70,16 +68,15 @@ withLogFile action = do openLogFile logFilePath else return logFileHandle - action logFileHandle'' - return (logFileHandle'', curDay) + action logFileHandle' + atomicWriteIORef state $ Just (logFileHandle', curDay) - put $ toDyn (logFileHandle', curDay) return Nothing fmtTime :: UTCTime -> String fmtTime = formatTime defaultTimeLocale "%F %T" -messageLogger :: MonadMsgHandler m => Message -> m (Maybe Command) +messageLogger :: MonadMsgHandler m => Message -> IORef LoggerState -> m (Maybe Command) messageLogger ChannelMsg { .. } = withLogFile $ \logFile -> TF.hprint logFile "[{}] {}: {}\n" $ TF.buildParams (fmtTime msgTime, userNick user, msg) @@ -107,4 +104,4 @@ messageLogger NickMsg { .. } = withLogFile $ \logFile -> TF.hprint logFile "[{}] ** {} CHANGED NICK TO {}\n" $ TF.buildParams (fmtTime msgTime, userNick user, nick) -messageLogger _ = return Nothing +messageLogger _ = const $ return Nothing diff --git a/Network/IRC/Handlers/SongSearch.hs b/Network/IRC/Handlers/SongSearch.hs index 6b8cab1..51444cb 100644 --- a/Network/IRC/Handlers/SongSearch.hs +++ b/Network/IRC/Handlers/SongSearch.hs @@ -1,6 +1,6 @@ {-# LANGUAGE RecordWildCards, OverloadedStrings, ScopedTypeVariables, NoImplicitPrelude, FlexibleContexts #-} -module Network.IRC.Handlers.SongSearch (getMsgHandler) where +module Network.IRC.Handlers.SongSearch (mkMsgHandler) where import qualified Data.Configurator as CF @@ -15,9 +15,9 @@ import Network.HTTP.Base import Network.IRC.Types -getMsgHandler :: MsgHandlerName -> Maybe MsgHandler -getMsgHandler "songsearch" = Just $ newMsgHandler { msgHandlerRun = songSearch } -getMsgHandler _ = Nothing +mkMsgHandler :: BotConfig -> MsgHandlerName -> IO (Maybe MsgHandler) +mkMsgHandler _ "songsearch" = return . Just $ newMsgHandler { msgHandlerRun = songSearch } +mkMsgHandler _ _ = return Nothing data Song = NoSong | Song { url :: Text, name :: Text, artist :: Text } deriving (Show, Eq) diff --git a/Network/IRC/Types.hs b/Network/IRC/Types.hs index a5a2de7..b1b8dde 100644 --- a/Network/IRC/Types.hs +++ b/Network/IRC/Types.hs @@ -6,15 +6,14 @@ module Network.IRC.Types User (..), Message (..), Command (..), BotConfig (..), BotStatus (..), Bot (..), IRC, runIRC, - MonadMsgHandler, runMsgHandler, initMsgHandler, exitMsgHandler, - MsgHandlerState, MsgHandlerStates, MsgHandler (..), newMsgHandler) + MonadMsgHandler, runMsgHandler, stopMsgHandler, + MsgHandler (..), newMsgHandler) where import ClassyPrelude import Control.Monad.Reader import Control.Monad.State import Data.Configurator.Types -import Data.Dynamic type Channel = Text type Nick = Text @@ -50,13 +49,13 @@ data Command = | JoinCmd deriving (Show, Eq) -data BotConfig = BotConfig { server :: !Text - , port :: !Int - , channel :: !Text - , botNick :: !Text - , botTimeout :: !Int - , msgHandlers :: ![MsgHandlerName] - , config :: !Config } +data BotConfig = BotConfig { server :: !Text + , port :: !Int + , channel :: !Text + , botNick :: !Text + , botTimeout :: !Int + , msgHandlerNames :: ![MsgHandlerName] + , config :: !Config } instance Show BotConfig where show BotConfig { .. } = "server = " ++ show server ++ "\n" ++ @@ -64,14 +63,11 @@ instance Show BotConfig where "channel = " ++ show channel ++ "\n" ++ "nick = " ++ show botNick ++ "\n" ++ "timeout = " ++ show botTimeout ++ "\n" ++ - "handlers = " ++ show msgHandlers + "handlers = " ++ show msgHandlerNames -type MsgHandlerState = Dynamic -type MsgHandlerStates = Map MsgHandlerName (MVar MsgHandlerState) - -data Bot = Bot { botConfig :: !BotConfig - , socket :: !Handle - , msgHandlerStates :: !MsgHandlerStates } +data Bot = Bot { botConfig :: !BotConfig + , socket :: !Handle + , msgHandlers :: !(Map MsgHandlerName MsgHandler) } data BotStatus = Connected | Disconnected | Joined | Kicked | Errored | Idle deriving (Show, Eq) @@ -87,38 +83,29 @@ newtype IRC a = IRC { _runIRC :: StateT BotStatus (ReaderT Bot IO) a } runIRC :: Bot -> BotStatus -> IRC a -> IO BotStatus runIRC bot botStatus = flip runReaderT bot . flip execStateT botStatus . _runIRC -newtype MsgHandlerT a = MsgHandlerT { _runMsgHandler :: StateT MsgHandlerState (ReaderT BotConfig IO) a } +newtype MsgHandlerT a = MsgHandlerT { _runMsgHandler :: ReaderT BotConfig IO a } deriving ( Functor , Applicative , Monad , MonadIO - , MonadState MsgHandlerState , MonadReader BotConfig ) -class ( MonadIO m, Applicative m - , MonadState MsgHandlerState m, MonadReader BotConfig m ) => MonadMsgHandler m where +class ( MonadIO m, Applicative m, MonadReader BotConfig m ) => MonadMsgHandler m where msgHandler :: MsgHandlerT a -> m a instance MonadMsgHandler MsgHandlerT where msgHandler = id -runMsgHandler :: MsgHandler -> BotConfig -> MsgHandlerState -> Message -> IO (Maybe Command, MsgHandlerState) -runMsgHandler MsgHandler { .. } botConfig msgHandlerState = - flip runReaderT botConfig . flip runStateT msgHandlerState . _runMsgHandler . msgHandlerRun +runMsgHandler :: MsgHandler -> BotConfig -> Message -> IO (Maybe Command) +runMsgHandler MsgHandler { .. } botConfig = flip runReaderT botConfig . _runMsgHandler . msgHandlerRun -initMsgHandler :: MsgHandler -> BotConfig -> IO MsgHandlerState -initMsgHandler MsgHandler { .. } botConfig = - flip runReaderT botConfig . flip execStateT (toDyn ()) . _runMsgHandler $ msgHandlerInit +stopMsgHandler :: MsgHandler -> BotConfig -> IO () +stopMsgHandler MsgHandler { .. } botConfig = + flip runReaderT botConfig . _runMsgHandler $ msgHandlerStop -exitMsgHandler :: MsgHandler -> BotConfig -> MsgHandlerState -> IO () -exitMsgHandler MsgHandler { .. } botConfig msgHandlerState = - flip runReaderT botConfig . flip evalStateT msgHandlerState . _runMsgHandler $ msgHandlerExit - -data MsgHandler = MsgHandler { msgHandlerInit :: !(forall m . MonadMsgHandler m => m ()) - , msgHandlerRun :: !(forall m . MonadMsgHandler m => Message -> m (Maybe Command)) - , msgHandlerExit :: !(forall m . MonadMsgHandler m => m ()) } +data MsgHandler = MsgHandler { msgHandlerRun :: !(forall m . MonadMsgHandler m => Message -> m (Maybe Command)) + , msgHandlerStop :: !(forall m . MonadMsgHandler m => m ()) } newMsgHandler :: MsgHandler -newMsgHandler = MsgHandler { msgHandlerInit = return () - , msgHandlerRun = const $ return Nothing - , msgHandlerExit = return () } +newMsgHandler = MsgHandler { msgHandlerRun = const $ return Nothing + , msgHandlerStop = return () }