abhin4v
/
hask-irc
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Hid message handler states from client. Much cleaner code.

master
Abhinav Sarkar 2014-05-12 02:29:26 +05:30
parent ff4030d7eb
commit 34bac20fa5
5 changed files with 102 additions and 129 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
Network/IRC/Client.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE RecordWildCards, ScopedTypeVariables, NoImplicitPrelude, OverloadedStrings, BangPatterns #-} {-# LANGUAGE RecordWildCards, ScopedTypeVariables, NoImplicitPrelude, OverloadedStrings #-}
module Network.IRC.Client (run) where module Network.IRC.Client (run) where
@ -9,7 +9,6 @@ import ClassyPrelude
import Control.Concurrent.Lifted import Control.Concurrent.Lifted
import Control.Monad.Reader hiding (forM_, foldM) import Control.Monad.Reader hiding (forM_, foldM)
import Control.Monad.State hiding (forM_, foldM) import Control.Monad.State hiding (forM_, foldM)
import Data.Maybe (fromJust)
import Network import Network
import System.IO (hSetBuffering, BufferMode(..)) import System.IO (hSetBuffering, BufferMode(..))
import System.Timeout import System.Timeout
@ -39,29 +38,29 @@ listenerLoop idleFor = do
bot@Bot { .. } <- ask bot@Bot { .. } <- ask
let nick = botNick botConfig let nick = botNick botConfig
nStatus <- liftIO $ do nStatus <- liftIO $
if idleFor >= (oneSec * botTimeout botConfig) if idleFor >= (oneSec * botTimeout botConfig)
then return Disconnected then return Disconnected
else do else do
when (status == Kicked) $ when (status == Kicked) $
threadDelay (5 * oneSec) >> sendCommand bot JoinCmd threadDelay (5 * oneSec) >> sendCommand bot JoinCmd
mLine <- map (map initEx) . timeout oneSec . hGetLine $ socket mLine <- map (map initEx) . timeout oneSec . hGetLine $ socket
case mLine of case mLine of
Nothing -> dispatchHandlers bot IdleMsg >> return Idle Nothing -> dispatchHandlers bot IdleMsg >> return Idle
Just line -> do Just line -> do
now <- getCurrentTime now <- getCurrentTime
debug $ "< " ++ line debug $ "< " ++ line
let message = msgFromLine botConfig now line let message = msgFromLine botConfig now line
nStatus <- case message of nStatus <- case message of
JoinMsg { .. } | userNick user == nick -> debug "Joined" >> return Joined JoinMsg { .. } | userNick user == nick -> debug "Joined" >> return Joined
KickMsg { .. } | kickedNick == nick -> debug "Kicked" >> return Kicked KickMsg { .. } | kickedNick == nick -> debug "Kicked" >> return Kicked
ModeMsg { user = Self, .. } -> sendCommand bot JoinCmd >> return Connected ModeMsg { user = Self, .. } -> sendCommand bot JoinCmd >> return Connected
_ -> return Connected _ -> return Connected
dispatchHandlers bot message dispatchHandlers bot message
return nStatus return nStatus
put nStatus put nStatus
case nStatus of case nStatus of
@ -71,49 +70,36 @@ listenerLoop idleFor = do
where where
dispatchHandlers bot@Bot { .. } message = dispatchHandlers bot@Bot { .. } message =
forM_ (msgHandlers botConfig) $ \msgHandlerName -> fork $ forM_ (mapToList msgHandlers) $ \(_, msgHandler) -> fork $
handle (\(e :: SomeException) -> debug $ "Exception! " ++ pack (show e)) $ do handle (\(e :: SomeException) -> debug $ "Exception! " ++ pack (show e)) $ do
let mMsgHandler = getMsgHandler msgHandlerName mCmd <- runMsgHandler msgHandler botConfig message
case mMsgHandler of case mCmd of
Nothing -> debug $ "No msg handler found with name: " ++ msgHandlerName Nothing -> return ()
Just msgHandler -> Just cmd -> sendCommand bot cmd
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
loadMsgHandlers :: BotConfig -> IO MsgHandlerStates loadMsgHandlers :: BotConfig -> IO (Map MsgHandlerName MsgHandler)
loadMsgHandlers botConfig@BotConfig { .. } = loadMsgHandlers botConfig@BotConfig { .. } =
flip (`foldM` mapFromList []) msgHandlers $ \hMap msgHandlerName -> do flip (`foldM` mempty) msgHandlerNames $ \hMap msgHandlerName -> do
debug $ "Loading msg handler: " ++ msgHandlerName debug $ "Loading msg handler: " ++ msgHandlerName
let mMsgHandler = getMsgHandler msgHandlerName mMsgHandler <- mkMsgHandler botConfig msgHandlerName
case mMsgHandler of case mMsgHandler of
Nothing -> debug ("No msg handler found with name: " ++ msgHandlerName) >> return hMap Nothing -> debug ("No msg handler found with name: " ++ msgHandlerName) >> return hMap
Just msgHandler -> do Just msgHandler -> return $ insertMap msgHandlerName msgHandler hMap
!msgHandlerState <- initMsgHandler msgHandler botConfig
mvMsgHandlerState <- newMVar msgHandlerState
return $ insertMap msgHandlerName mvMsgHandlerState hMap
unloadMsgHandlers :: Bot -> IO () unloadMsgHandlers :: Bot -> IO ()
unloadMsgHandlers Bot { .. } = unloadMsgHandlers Bot { .. } =
forM_ (mapToList msgHandlerStates) $ \(msgHandlerName, msgHandlerState) -> do forM_ (mapToList msgHandlers) $ \(msgHandlerName, msgHandler) -> do
debug $ "Unloading msg handler: " ++ msgHandlerName debug $ "Unloading msg handler: " ++ msgHandlerName
let mMsgHandler = getMsgHandler msgHandlerName stopMsgHandler msgHandler botConfig
case mMsgHandler of
Nothing -> debug ("No msg handler found with name: " ++ msgHandlerName)
Just msgHandler -> takeMVar msgHandlerState >>= exitMsgHandler msgHandler botConfig
connect :: BotConfig -> IO Bot connect :: BotConfig -> IO Bot
connect botConfig@BotConfig { .. } = do connect botConfig@BotConfig { .. } = do
debug "Connecting ..." debug "Connecting ..."
socket <- connectToWithRetry socket <- connectToWithRetry
hSetBuffering socket LineBuffering hSetBuffering socket LineBuffering
msgHandlerStates <- loadMsgHandlers botConfig msgHandlers <- loadMsgHandlers botConfig
debug "Connected" debug "Connected"
return $ Bot botConfig socket msgHandlerStates return $ Bot botConfig socket msgHandlers
where where
connectToWithRetry = connectTo (unpack server) (PortNumber (fromIntegral port)) connectToWithRetry = connectTo (unpack server) (PortNumber (fromIntegral port))
`catch` (\(e :: SomeException) -> do `catch` (\(e :: SomeException) -> do
@ -130,7 +116,7 @@ disconnect bot@Bot { .. } = do
addCoreMsgHandlers :: BotConfig -> BotConfig addCoreMsgHandlers :: BotConfig -> BotConfig
addCoreMsgHandlers botConfig = addCoreMsgHandlers botConfig =
botConfig { msgHandlers = hashNub $ msgHandlers botConfig ++ coreMsgHandlerNames } botConfig { msgHandlerNames = hashNub $ msgHandlerNames botConfig ++ coreMsgHandlerNames }
run :: BotConfig -> IO () run :: BotConfig -> IO ()
run botConfig' = withSocketsDo $ do run botConfig' = withSocketsDo $ do

19
Network/IRC/Handlers.hs
View File

@ -1,12 +1,12 @@
{-# LANGUAGE RecordWildCards, OverloadedStrings, NoImplicitPrelude, FlexibleContexts #-} {-# 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.MessageLogger as L
import qualified Network.IRC.Handlers.SongSearch as SS import qualified Network.IRC.Handlers.SongSearch as SS
import ClassyPrelude import ClassyPrelude
import Control.Monad.Reader import Control.Monad.Reader.Class
import Data.Text (strip) import Data.Text (strip)
import Network.IRC.Types import Network.IRC.Types
@ -17,12 +17,15 @@ clean = toLower . strip
coreMsgHandlerNames :: [Text] coreMsgHandlerNames :: [Text]
coreMsgHandlerNames = ["pingpong", "messagelogger"] coreMsgHandlerNames = ["pingpong", "messagelogger"]
getMsgHandler :: MsgHandlerName -> Maybe MsgHandler mkMsgHandler :: BotConfig -> MsgHandlerName -> IO (Maybe MsgHandler)
getMsgHandler "greeter" = Just $ newMsgHandler { msgHandlerRun = greeter } mkMsgHandler _ "greeter" = return . Just $ newMsgHandler { msgHandlerRun = greeter }
getMsgHandler "welcomer" = Just $ newMsgHandler { msgHandlerRun = welcomer } mkMsgHandler _ "welcomer" = return . Just $ newMsgHandler { msgHandlerRun = welcomer }
getMsgHandler "pingpong" = Just $ newMsgHandler { msgHandlerRun = pingPong } mkMsgHandler _ "pingpong" = return . Just $ newMsgHandler { msgHandlerRun = pingPong }
getMsgHandler name = listToMaybe $ mapMaybe (\f -> f name) mkMsgHandler botConfig name =
[L.getMsgHandler, SS.getMsgHandler] 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 :: MonadMsgHandler m => Message -> m (Maybe Command)
pingPong Ping { .. } = return . Just $ Pong msg pingPong Ping { .. } = return . Just $ Pong msg

63
Network/IRC/Handlers/MessageLogger.hs
View File

@ -1,6 +1,6 @@
{-# LANGUAGE RecordWildCards, NoImplicitPrelude, OverloadedStrings, FlexibleContexts, ScopedTypeVariables #-} {-# 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.Configurator as C
import qualified Data.Text.Format as TF 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 ClassyPrelude hiding (try, (</>), (<.>), FilePath)
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.State
import Data.Dynamic
import Data.Time (diffDays) import Data.Time (diffDays)
import System.Directory import System.Directory
import System.FilePath import System.FilePath
@ -17,11 +15,15 @@ import System.IO (openFile, IOMode(..), hSetBuffering, BufferMode(..))
import Network.IRC.Types import Network.IRC.Types
getMsgHandler :: MsgHandlerName -> Maybe MsgHandler type LoggerState = Maybe (Handle, Day)
getMsgHandler "messagelogger" = Just $ newMsgHandler { msgHandlerInit = initMessageLogger
, msgHandlerRun = messageLogger mkMsgHandler :: BotConfig -> MsgHandlerName -> IO (Maybe MsgHandler)
, msgHandlerExit = exitMessageLogger } mkMsgHandler botConfig "messagelogger" = do
getMsgHandler _ = Nothing 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 -> IO FilePath
getLogFilePath BotConfig { .. } = do getLogFilePath BotConfig { .. } = do
@ -35,33 +37,29 @@ openLogFile logFilePath = do
hSetBuffering logFileHandle LineBuffering hSetBuffering logFileHandle LineBuffering
return logFileHandle return logFileHandle
initMessageLogger :: MonadMsgHandler m => m () initMessageLogger :: BotConfig -> IORef LoggerState -> IO ()
initMessageLogger = do initMessageLogger botConfig state = do
botConfig <- ask logFilePath <- getLogFilePath botConfig
(logFileHandle, curDay) <- liftIO $ do logFileHandle <- openLogFile logFilePath
logFilePath <- getLogFilePath botConfig time <- getModificationTime logFilePath
logFileHandle <- openLogFile logFilePath atomicWriteIORef state $ Just (logFileHandle, utctDay time)
time <- getModificationTime logFilePath
return (logFileHandle, utctDay time)
put $ toDyn (logFileHandle, curDay)
exitMessageLogger :: MonadMsgHandler m => m () exitMessageLogger :: MonadMsgHandler m => IORef LoggerState -> m ()
exitMessageLogger = do exitMessageLogger state = liftIO $ do
mHandle <- map fromDynamic get mHandle <- readIORef state
case mHandle of case mHandle of
Nothing -> return () Nothing -> return ()
Just (logFileHandle, _ :: UTCTime) -> liftIO $ hClose logFileHandle Just (logFileHandle, _ :: Day) -> hClose logFileHandle
withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> m (Maybe Command) withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m (Maybe Command)
withLogFile action = do withLogFile action state = do
botConfig <- ask botConfig <- ask
(logFileHandle, prevDay) <- map (`fromDyn` error "No log file set") get liftIO $ do
Just (logFileHandle, prevDay) <- readIORef state
(logFileHandle', curDay) <- liftIO $ do
curDay <- map utctDay getCurrentTime curDay <- map utctDay getCurrentTime
let diff = diffDays curDay prevDay let diff = diffDays curDay prevDay
logFileHandle'' <- if diff >= 1 logFileHandle' <- if diff >= 1
then do then do
hClose logFileHandle hClose logFileHandle
logFilePath <- getLogFilePath botConfig logFilePath <- getLogFilePath botConfig
@ -70,16 +68,15 @@ withLogFile action = do
openLogFile logFilePath openLogFile logFilePath
else return logFileHandle else return logFileHandle
action logFileHandle'' action logFileHandle'
return (logFileHandle'', curDay) atomicWriteIORef state $ Just (logFileHandle', curDay)
put $ toDyn (logFileHandle', curDay)
return Nothing return Nothing
fmtTime :: UTCTime -> String fmtTime :: UTCTime -> String
fmtTime = formatTime defaultTimeLocale "%F %T" 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 -> messageLogger ChannelMsg { .. } = withLogFile $ \logFile ->
TF.hprint logFile "[{}] {}: {}\n" $ TF.buildParams (fmtTime msgTime, userNick user, msg) 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.hprint logFile "[{}] ** {} CHANGED NICK TO {}\n" $
TF.buildParams (fmtTime msgTime, userNick user, nick) TF.buildParams (fmtTime msgTime, userNick user, nick)
messageLogger _ = return Nothing messageLogger _ = const $ return Nothing

8
Network/IRC/Handlers/SongSearch.hs
View File

@ -1,6 +1,6 @@
{-# LANGUAGE RecordWildCards, OverloadedStrings, ScopedTypeVariables, NoImplicitPrelude, FlexibleContexts #-} {-# 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 import qualified Data.Configurator as CF
@ -15,9 +15,9 @@ import Network.HTTP.Base
import Network.IRC.Types import Network.IRC.Types
getMsgHandler :: MsgHandlerName -> Maybe MsgHandler mkMsgHandler :: BotConfig -> MsgHandlerName -> IO (Maybe MsgHandler)
getMsgHandler "songsearch" = Just $ newMsgHandler { msgHandlerRun = songSearch } mkMsgHandler _ "songsearch" = return . Just $ newMsgHandler { msgHandlerRun = songSearch }
getMsgHandler _ = Nothing mkMsgHandler _ _ = return Nothing
data Song = NoSong | Song { url :: Text, name :: Text, artist :: Text } data Song = NoSong | Song { url :: Text, name :: Text, artist :: Text }
deriving (Show, Eq) deriving (Show, Eq)

61
Network/IRC/Types.hs
View File

@ -6,15 +6,14 @@ module Network.IRC.Types
User (..), Message (..), Command (..), User (..), Message (..), Command (..),
BotConfig (..), BotStatus (..), Bot (..), BotConfig (..), BotStatus (..), Bot (..),
IRC, runIRC, IRC, runIRC,
MonadMsgHandler, runMsgHandler, initMsgHandler, exitMsgHandler, MonadMsgHandler, runMsgHandler, stopMsgHandler,
MsgHandlerState, MsgHandlerStates, MsgHandler (..), newMsgHandler) MsgHandler (..), newMsgHandler)
where where
import ClassyPrelude import ClassyPrelude
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.State import Control.Monad.State
import Data.Configurator.Types import Data.Configurator.Types
import Data.Dynamic
type Channel = Text type Channel = Text
type Nick = Text type Nick = Text
@ -50,13 +49,13 @@ data Command =
| JoinCmd | JoinCmd
deriving (Show, Eq) deriving (Show, Eq)
data BotConfig = BotConfig { server :: !Text data BotConfig = BotConfig { server :: !Text
, port :: !Int , port :: !Int
, channel :: !Text , channel :: !Text
, botNick :: !Text , botNick :: !Text
, botTimeout :: !Int , botTimeout :: !Int
, msgHandlers :: ![MsgHandlerName] , msgHandlerNames :: ![MsgHandlerName]
, config :: !Config } , config :: !Config }
instance Show BotConfig where instance Show BotConfig where
show BotConfig { .. } = "server = " ++ show server ++ "\n" ++ show BotConfig { .. } = "server = " ++ show server ++ "\n" ++
@ -64,14 +63,11 @@ instance Show BotConfig where
"channel = " ++ show channel ++ "\n" ++ "channel = " ++ show channel ++ "\n" ++
"nick = " ++ show botNick ++ "\n" ++ "nick = " ++ show botNick ++ "\n" ++
"timeout = " ++ show botTimeout ++ "\n" ++ "timeout = " ++ show botTimeout ++ "\n" ++
"handlers = " ++ show msgHandlers "handlers = " ++ show msgHandlerNames
type MsgHandlerState = Dynamic data Bot = Bot { botConfig :: !BotConfig
type MsgHandlerStates = Map MsgHandlerName (MVar MsgHandlerState) , socket :: !Handle
, msgHandlers :: !(Map MsgHandlerName MsgHandler) }
data Bot = Bot { botConfig :: !BotConfig
, socket :: !Handle
, msgHandlerStates :: !MsgHandlerStates }
data BotStatus = Connected | Disconnected | Joined | Kicked | Errored | Idle data BotStatus = Connected | Disconnected | Joined | Kicked | Errored | Idle
deriving (Show, Eq) 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 -> IRC a -> IO BotStatus
runIRC bot botStatus = flip runReaderT bot . flip execStateT botStatus . _runIRC 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 deriving ( Functor
, Applicative , Applicative
, Monad , Monad
, MonadIO , MonadIO
, MonadState MsgHandlerState
, MonadReader BotConfig ) , MonadReader BotConfig )
class ( MonadIO m, Applicative m class ( MonadIO m, Applicative m, MonadReader BotConfig m ) => MonadMsgHandler m where
, MonadState MsgHandlerState m, MonadReader BotConfig m ) => MonadMsgHandler m where
msgHandler :: MsgHandlerT a -> m a msgHandler :: MsgHandlerT a -> m a
instance MonadMsgHandler MsgHandlerT where instance MonadMsgHandler MsgHandlerT where
msgHandler = id msgHandler = id
runMsgHandler :: MsgHandler -> BotConfig -> MsgHandlerState -> Message -> IO (Maybe Command, MsgHandlerState) runMsgHandler :: MsgHandler -> BotConfig -> Message -> IO (Maybe Command)
runMsgHandler MsgHandler { .. } botConfig msgHandlerState = runMsgHandler MsgHandler { .. } botConfig = flip runReaderT botConfig . _runMsgHandler . msgHandlerRun
flip runReaderT botConfig . flip runStateT msgHandlerState . _runMsgHandler . msgHandlerRun
initMsgHandler :: MsgHandler -> BotConfig -> IO MsgHandlerState stopMsgHandler :: MsgHandler -> BotConfig -> IO ()
initMsgHandler MsgHandler { .. } botConfig = stopMsgHandler MsgHandler { .. } botConfig =
flip runReaderT botConfig . flip execStateT (toDyn ()) . _runMsgHandler $ msgHandlerInit flip runReaderT botConfig . _runMsgHandler $ msgHandlerStop
exitMsgHandler :: MsgHandler -> BotConfig -> MsgHandlerState -> IO () data MsgHandler = MsgHandler { msgHandlerRun :: !(forall m . MonadMsgHandler m => Message -> m (Maybe Command))
exitMsgHandler MsgHandler { .. } botConfig msgHandlerState = , msgHandlerStop :: !(forall m . MonadMsgHandler m => m ()) }
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 ()) }
newMsgHandler :: MsgHandler newMsgHandler :: MsgHandler
newMsgHandler = MsgHandler { msgHandlerInit = return () newMsgHandler = MsgHandler { msgHandlerRun = const $ return Nothing
, msgHandlerRun = const $ return Nothing , msgHandlerStop = return () }
, msgHandlerExit = return () }