Hid message handler states from client. Much cleaner code.
This commit is contained in:
parent
ff4030d7eb
commit
34bac20fa5
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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 () }
|
||||
|
||||
Loading…
Reference in New Issue
Block a user