Fixed the state handling in message handlers
This commit is contained in:
parent
f1f80d2446
commit
8cf2872432
|
|
@ -1,4 +1,4 @@
|
|||
{-# LANGUAGE RecordWildCards, ScopedTypeVariables, NoImplicitPrelude, OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards, ScopedTypeVariables, NoImplicitPrelude, OverloadedStrings, BangPatterns #-}
|
||||
|
||||
module Network.IRC.Client (run) where
|
||||
|
||||
|
|
@ -6,7 +6,7 @@ import qualified Data.Text.Format as TF
|
|||
import qualified Data.Text.Format.Params as TF
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.Lifted
|
||||
import Control.Monad.Reader hiding (forM_, foldM)
|
||||
import Control.Monad.State hiding (forM_, foldM)
|
||||
import Data.Maybe (fromJust)
|
||||
|
|
@ -31,7 +31,7 @@ sendCommand Bot { .. } reply = do
|
|||
time <- getCurrentTime
|
||||
let line = lineFromCommand botConfig reply
|
||||
TF.hprint socket "{}\r\n" $ TF.Only line
|
||||
TF.print "[{}} > {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, line)
|
||||
TF.print "[{}] > {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, line)
|
||||
|
||||
listen :: IRC ()
|
||||
listen = do
|
||||
|
|
@ -57,22 +57,45 @@ listen = do
|
|||
ModeMsg { user = Self, .. } -> sendCommand bot JoinCmd >> return status
|
||||
_ -> return status
|
||||
|
||||
forM_ (msgHandlers botConfig) $ \msgHandlerName -> forkIO $ do
|
||||
forM_ (msgHandlers botConfig) $ \msgHandlerName -> fork $ do
|
||||
let mMsgHandler = getMsgHandler msgHandlerName
|
||||
case mMsgHandler of
|
||||
Nothing -> debug $ "No msg handler found with name: " ++ msgHandlerName
|
||||
Just msgHandler -> do
|
||||
Just msgHandler ->
|
||||
let msgHandlerState = fromJust . lookup msgHandlerName $ msgHandlerStates
|
||||
mCmd <- runMsgHandler msgHandler botConfig msgHandlerState message
|
||||
case mCmd of
|
||||
Nothing -> return ()
|
||||
Just cmd -> sendCommand bot cmd
|
||||
in modifyMVar_ msgHandlerState $ \hState -> do
|
||||
!(mCmd, nhState) <- runMsgHandler msgHandler botConfig hState message
|
||||
case mCmd of
|
||||
Nothing -> return ()
|
||||
Just cmd -> sendCommand bot cmd
|
||||
return nhState
|
||||
|
||||
return nStatus
|
||||
|
||||
put nStatus
|
||||
when (nStatus /= Disconnected) listen
|
||||
|
||||
loadMsgHandlers :: BotConfig -> IO MsgHandlerStates
|
||||
loadMsgHandlers botConfig@BotConfig { .. } =
|
||||
flip (`foldM` mapFromList []) msgHandlers $ \hMap msgHandlerName -> do
|
||||
debug $ "Loading msg handler: " ++ msgHandlerName
|
||||
let mMsgHandler = getMsgHandler 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
|
||||
|
||||
unloadMsgHandlers :: Bot -> IO ()
|
||||
unloadMsgHandlers Bot { .. } =
|
||||
forM_ (mapToList msgHandlerStates) $ \(msgHandlerName, msgHandlerState) -> 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
|
||||
|
||||
connect :: BotConfig -> IO Bot
|
||||
connect botConfig@BotConfig { .. } = do
|
||||
debug "Connecting ..."
|
||||
|
|
@ -88,27 +111,6 @@ connect botConfig@BotConfig { .. } = do
|
|||
threadDelay (5 * oneSec)
|
||||
connectToWithRetry)
|
||||
|
||||
loadMsgHandlers :: BotConfig -> IO MsgHandlerStates
|
||||
loadMsgHandlers botConfig@BotConfig { .. } =
|
||||
flip (`foldM` mapFromList []) msgHandlers $ \hMap msgHandlerName -> do
|
||||
debug $ "Loading msg handler: " ++ msgHandlerName
|
||||
let mMsgHandler = getMsgHandler msgHandlerName
|
||||
case mMsgHandler of
|
||||
Nothing -> debug ("No msg handler found with name: " ++ msgHandlerName) >> return hMap
|
||||
Just msgHandler -> do
|
||||
msgHandlerState <- initMsgHandler msgHandler botConfig
|
||||
return $ insertMap msgHandlerName msgHandlerState hMap
|
||||
|
||||
unloadMsgHandlers :: Bot -> IO ()
|
||||
unloadMsgHandlers Bot { .. } =
|
||||
forM_ (mapToList msgHandlerStates) $ \(msgHandlerName, msgHandlerState) -> do
|
||||
debug $ "Unloading msg handler: " ++ msgHandlerName
|
||||
let mMsgHandler = getMsgHandler msgHandlerName
|
||||
case mMsgHandler of
|
||||
Nothing -> debug ("No msg handler found with name: " ++ msgHandlerName)
|
||||
Just msgHandler -> exitMsgHandler msgHandler botConfig msgHandlerState
|
||||
|
||||
|
||||
disconnect :: Bot -> IO ()
|
||||
disconnect bot@Bot { .. } = do
|
||||
debug "Disconnecting ..."
|
||||
|
|
|
|||
|
|
@ -56,27 +56,27 @@ fmtTime :: UTCTime -> String
|
|||
fmtTime = formatTime defaultTimeLocale "%F %T"
|
||||
|
||||
messageLogger :: MonadMsgHandler m => Message -> m (Maybe Command)
|
||||
messageLogger ChannelMsg { .. } = withLogFile $ \logFileHandle ->
|
||||
TF.hprint logFileHandle "[{}] {}: {}\n" $ TF.buildParams (fmtTime msgTime, userNick user, msg)
|
||||
messageLogger ChannelMsg { .. } = withLogFile $ \logFile ->
|
||||
TF.hprint logFile "[{}] {}: {}\n" $ TF.buildParams (fmtTime msgTime, userNick user, msg)
|
||||
|
||||
messageLogger KickMsg { .. } = withLogFile $ \logFileHandle ->
|
||||
TF.hprint logFileHandle "[{}] ** {} KICKED {} :{}\n" $
|
||||
messageLogger KickMsg { .. } = withLogFile $ \logFile ->
|
||||
TF.hprint logFile "[{}] ** {} KICKED {} :{}\n" $
|
||||
TF.buildParams (fmtTime msgTime, userNick user, kickedNick, msg)
|
||||
|
||||
messageLogger JoinMsg { .. } = withLogFile $ \logFileHandle ->
|
||||
TF.hprint logFileHandle "[{}] ** {} JOINED\n" $
|
||||
messageLogger JoinMsg { .. } = withLogFile $ \logFile ->
|
||||
TF.hprint logFile "[{}] ** {} JOINED\n" $
|
||||
TF.buildParams (fmtTime msgTime, userNick user)
|
||||
|
||||
messageLogger PartMsg { .. } = withLogFile $ \logFileHandle ->
|
||||
TF.hprint logFileHandle "[{}] ** {} PARTED :{}\n" $
|
||||
messageLogger PartMsg { .. } = withLogFile $ \logFile ->
|
||||
TF.hprint logFile "[{}] ** {} PARTED :{}\n" $
|
||||
TF.buildParams (fmtTime msgTime, userNick user, msg)
|
||||
|
||||
messageLogger QuitMsg { .. } = withLogFile $ \logFileHandle ->
|
||||
TF.hprint logFileHandle "[{}] ** {} QUIT :{}\n" $
|
||||
messageLogger QuitMsg { .. } = withLogFile $ \logFile ->
|
||||
TF.hprint logFile "[{}] ** {} QUIT :{}\n" $
|
||||
TF.buildParams (fmtTime msgTime, userNick user, msg)
|
||||
|
||||
messageLogger NickMsg { .. } = withLogFile $ \logFileHandle ->
|
||||
TF.hprint logFileHandle "[{}] ** {} CHANGED NICK TO {}\n" $
|
||||
messageLogger NickMsg { .. } = withLogFile $ \logFile ->
|
||||
TF.hprint logFile "[{}] ** {} CHANGED NICK TO {}\n" $
|
||||
TF.buildParams (fmtTime msgTime, userNick user, nick)
|
||||
|
||||
messageLogger _ = return Nothing
|
||||
|
|
|
|||
|
|
@ -64,11 +64,12 @@ instance Show BotConfig where
|
|||
"timeout = " ++ show botTimeout ++ "\n" ++
|
||||
"handlers = " ++ show msgHandlers
|
||||
|
||||
type MsgHandlerStates = Map MsgHandlerName MsgHandlerState
|
||||
type MsgHandlerState = Dynamic
|
||||
type MsgHandlerStates = Map MsgHandlerName (MVar MsgHandlerState)
|
||||
|
||||
data Bot = Bot { botConfig :: !BotConfig
|
||||
, socket :: !Handle
|
||||
, msgHandlerStates :: !MsgHandlerStates}
|
||||
, msgHandlerStates :: !MsgHandlerStates }
|
||||
|
||||
data BotStatus = Connected | Disconnected | Joined | Kicked | Errored
|
||||
deriving (Show, Eq)
|
||||
|
|
@ -79,31 +80,29 @@ newtype IRC a = IRC { _runIRC :: StateT BotStatus (ReaderT Bot IO) a }
|
|||
, Monad
|
||||
, MonadIO
|
||||
, MonadReader Bot
|
||||
, MonadState BotStatus)
|
||||
, MonadState BotStatus )
|
||||
|
||||
runIRC :: Bot -> BotStatus -> IRC a -> IO BotStatus
|
||||
runIRC bot botStatus = flip runReaderT bot . flip execStateT botStatus . _runIRC
|
||||
|
||||
type MsgHandlerState = Dynamic
|
||||
|
||||
newtype MsgHandlerT a = MsgHandlerT { _runMsgHandler :: StateT MsgHandlerState (ReaderT BotConfig IO) a }
|
||||
deriving ( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
, MonadIO
|
||||
, MonadState MsgHandlerState
|
||||
, MonadReader BotConfig)
|
||||
, MonadReader BotConfig )
|
||||
|
||||
class ( MonadIO m, Applicative m
|
||||
, MonadState MsgHandlerState m, MonadReader BotConfig m) => MonadMsgHandler m where
|
||||
, MonadState MsgHandlerState 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)
|
||||
runMsgHandler :: MsgHandler -> BotConfig -> MsgHandlerState -> Message -> IO (Maybe Command, MsgHandlerState)
|
||||
runMsgHandler MsgHandler { .. } botConfig msgHandlerState =
|
||||
flip runReaderT botConfig . flip evalStateT msgHandlerState . _runMsgHandler . msgHandlerRun
|
||||
flip runReaderT botConfig . flip runStateT msgHandlerState . _runMsgHandler . msgHandlerRun
|
||||
|
||||
initMsgHandler :: MsgHandler -> BotConfig -> IO MsgHandlerState
|
||||
initMsgHandler MsgHandler { .. } botConfig =
|
||||
|
|
|
|||
|
|
@ -52,7 +52,8 @@ library
|
|||
build-depends: base >=4.5 && <4.7, text >=0.11 && <0.12, mtl >=2.1 && <2.2,
|
||||
network >=2.3 && <2.5, configurator >= 0.2, time >=1.4.0,
|
||||
curl-aeson ==0.0.3, aeson >=0.6.0.0, HTTP, transformers >=0.3,
|
||||
classy-prelude ==0.9.1, text-format >= 0.3.1, filepath >=1.3, directory >=1.2
|
||||
classy-prelude ==0.9.1, text-format >= 0.3.1, filepath >=1.3, directory >=1.2,
|
||||
lifted-base >=0.2
|
||||
|
||||
exposed-modules: Network.IRC.Types, Network.IRC.Protocol,
|
||||
Network.IRC.Handlers, Network.IRC.Client
|
||||
|
|
@ -76,7 +77,8 @@ executable hask-irc
|
|||
build-depends: base >=4.5 && <4.7, text >=0.11 && <0.12, mtl >=2.1 && <2.2,
|
||||
network >=2.3 && <2.5, configurator >= 0.2, time >=1.4.0,
|
||||
curl-aeson ==0.0.3, aeson >=0.6.0.0, HTTP, transformers >=0.3,
|
||||
classy-prelude ==0.9.1, text-format >= 0.3.1, filepath >=1.3, directory >=1.2
|
||||
classy-prelude ==0.9.1, text-format >= 0.3.1, filepath >=1.3, directory >=1.2,
|
||||
lifted-base >=0.2
|
||||
|
||||
-- Directories containing source files.
|
||||
-- hs-source-dirs:
|
||||
|
|
|
|||
Loading…
Reference in New Issue