Hid message handler states from client. Much cleaner code.

This commit is contained in:
Abhinav Sarkar 2014-05-12 02:29:26 +05:30
parent ff4030d7eb
commit 34bac20fa5
5 changed files with 102 additions and 129 deletions

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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)

View File

@ -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 () }