Fixed the state handling in message handlers
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
|
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 qualified Data.Text.Format.Params as TF
|
||||||
|
|
||||||
import ClassyPrelude
|
import ClassyPrelude
|
||||||
import Control.Concurrent
|
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 Data.Maybe (fromJust)
|
||||||
|
@ -31,7 +31,7 @@ sendCommand Bot { .. } reply = do
|
||||||
time <- getCurrentTime
|
time <- getCurrentTime
|
||||||
let line = lineFromCommand botConfig reply
|
let line = lineFromCommand botConfig reply
|
||||||
TF.hprint socket "{}\r\n" $ TF.Only line
|
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 :: IRC ()
|
||||||
listen = do
|
listen = do
|
||||||
|
@ -57,22 +57,45 @@ listen = do
|
||||||
ModeMsg { user = Self, .. } -> sendCommand bot JoinCmd >> return status
|
ModeMsg { user = Self, .. } -> sendCommand bot JoinCmd >> return status
|
||||||
_ -> return status
|
_ -> return status
|
||||||
|
|
||||||
forM_ (msgHandlers botConfig) $ \msgHandlerName -> forkIO $ do
|
forM_ (msgHandlers botConfig) $ \msgHandlerName -> fork $ do
|
||||||
let mMsgHandler = getMsgHandler msgHandlerName
|
let mMsgHandler = getMsgHandler msgHandlerName
|
||||||
case mMsgHandler of
|
case mMsgHandler of
|
||||||
Nothing -> debug $ "No msg handler found with name: " ++ msgHandlerName
|
Nothing -> debug $ "No msg handler found with name: " ++ msgHandlerName
|
||||||
Just msgHandler -> do
|
Just msgHandler ->
|
||||||
let msgHandlerState = fromJust . lookup msgHandlerName $ msgHandlerStates
|
let msgHandlerState = fromJust . lookup msgHandlerName $ msgHandlerStates
|
||||||
mCmd <- runMsgHandler msgHandler botConfig msgHandlerState message
|
in modifyMVar_ msgHandlerState $ \hState -> do
|
||||||
case mCmd of
|
!(mCmd, nhState) <- runMsgHandler msgHandler botConfig hState message
|
||||||
Nothing -> return ()
|
case mCmd of
|
||||||
Just cmd -> sendCommand bot cmd
|
Nothing -> return ()
|
||||||
|
Just cmd -> sendCommand bot cmd
|
||||||
|
return nhState
|
||||||
|
|
||||||
return nStatus
|
return nStatus
|
||||||
|
|
||||||
put nStatus
|
put nStatus
|
||||||
when (nStatus /= Disconnected) listen
|
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 -> IO Bot
|
||||||
connect botConfig@BotConfig { .. } = do
|
connect botConfig@BotConfig { .. } = do
|
||||||
debug "Connecting ..."
|
debug "Connecting ..."
|
||||||
|
@ -88,27 +111,6 @@ connect botConfig@BotConfig { .. } = do
|
||||||
threadDelay (5 * oneSec)
|
threadDelay (5 * oneSec)
|
||||||
connectToWithRetry)
|
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 -> IO ()
|
||||||
disconnect bot@Bot { .. } = do
|
disconnect bot@Bot { .. } = do
|
||||||
debug "Disconnecting ..."
|
debug "Disconnecting ..."
|
||||||
|
|
|
@ -56,27 +56,27 @@ fmtTime :: UTCTime -> String
|
||||||
fmtTime = formatTime defaultTimeLocale "%F %T"
|
fmtTime = formatTime defaultTimeLocale "%F %T"
|
||||||
|
|
||||||
messageLogger :: MonadMsgHandler m => Message -> m (Maybe Command)
|
messageLogger :: MonadMsgHandler m => Message -> m (Maybe Command)
|
||||||
messageLogger ChannelMsg { .. } = withLogFile $ \logFileHandle ->
|
messageLogger ChannelMsg { .. } = withLogFile $ \logFile ->
|
||||||
TF.hprint logFileHandle "[{}] {}: {}\n" $ TF.buildParams (fmtTime msgTime, userNick user, msg)
|
TF.hprint logFile "[{}] {}: {}\n" $ TF.buildParams (fmtTime msgTime, userNick user, msg)
|
||||||
|
|
||||||
messageLogger KickMsg { .. } = withLogFile $ \logFileHandle ->
|
messageLogger KickMsg { .. } = withLogFile $ \logFile ->
|
||||||
TF.hprint logFileHandle "[{}] ** {} KICKED {} :{}\n" $
|
TF.hprint logFile "[{}] ** {} KICKED {} :{}\n" $
|
||||||
TF.buildParams (fmtTime msgTime, userNick user, kickedNick, msg)
|
TF.buildParams (fmtTime msgTime, userNick user, kickedNick, msg)
|
||||||
|
|
||||||
messageLogger JoinMsg { .. } = withLogFile $ \logFileHandle ->
|
messageLogger JoinMsg { .. } = withLogFile $ \logFile ->
|
||||||
TF.hprint logFileHandle "[{}] ** {} JOINED\n" $
|
TF.hprint logFile "[{}] ** {} JOINED\n" $
|
||||||
TF.buildParams (fmtTime msgTime, userNick user)
|
TF.buildParams (fmtTime msgTime, userNick user)
|
||||||
|
|
||||||
messageLogger PartMsg { .. } = withLogFile $ \logFileHandle ->
|
messageLogger PartMsg { .. } = withLogFile $ \logFile ->
|
||||||
TF.hprint logFileHandle "[{}] ** {} PARTED :{}\n" $
|
TF.hprint logFile "[{}] ** {} PARTED :{}\n" $
|
||||||
TF.buildParams (fmtTime msgTime, userNick user, msg)
|
TF.buildParams (fmtTime msgTime, userNick user, msg)
|
||||||
|
|
||||||
messageLogger QuitMsg { .. } = withLogFile $ \logFileHandle ->
|
messageLogger QuitMsg { .. } = withLogFile $ \logFile ->
|
||||||
TF.hprint logFileHandle "[{}] ** {} QUIT :{}\n" $
|
TF.hprint logFile "[{}] ** {} QUIT :{}\n" $
|
||||||
TF.buildParams (fmtTime msgTime, userNick user, msg)
|
TF.buildParams (fmtTime msgTime, userNick user, msg)
|
||||||
|
|
||||||
messageLogger NickMsg { .. } = withLogFile $ \logFileHandle ->
|
messageLogger NickMsg { .. } = withLogFile $ \logFile ->
|
||||||
TF.hprint logFileHandle "[{}] ** {} 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 _ = return Nothing
|
||||||
|
|
|
@ -64,11 +64,12 @@ instance Show BotConfig where
|
||||||
"timeout = " ++ show botTimeout ++ "\n" ++
|
"timeout = " ++ show botTimeout ++ "\n" ++
|
||||||
"handlers = " ++ show msgHandlers
|
"handlers = " ++ show msgHandlers
|
||||||
|
|
||||||
type MsgHandlerStates = Map MsgHandlerName MsgHandlerState
|
type MsgHandlerState = Dynamic
|
||||||
|
type MsgHandlerStates = Map MsgHandlerName (MVar MsgHandlerState)
|
||||||
|
|
||||||
data Bot = Bot { botConfig :: !BotConfig
|
data Bot = Bot { botConfig :: !BotConfig
|
||||||
, socket :: !Handle
|
, socket :: !Handle
|
||||||
, msgHandlerStates :: !MsgHandlerStates}
|
, msgHandlerStates :: !MsgHandlerStates }
|
||||||
|
|
||||||
data BotStatus = Connected | Disconnected | Joined | Kicked | Errored
|
data BotStatus = Connected | Disconnected | Joined | Kicked | Errored
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
@ -79,31 +80,29 @@ newtype IRC a = IRC { _runIRC :: StateT BotStatus (ReaderT Bot IO) a }
|
||||||
, Monad
|
, Monad
|
||||||
, MonadIO
|
, MonadIO
|
||||||
, MonadReader Bot
|
, MonadReader Bot
|
||||||
, MonadState BotStatus)
|
, MonadState BotStatus )
|
||||||
|
|
||||||
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
|
||||||
|
|
||||||
type MsgHandlerState = Dynamic
|
|
||||||
|
|
||||||
newtype MsgHandlerT a = MsgHandlerT { _runMsgHandler :: StateT MsgHandlerState (ReaderT BotConfig IO) a }
|
newtype MsgHandlerT a = MsgHandlerT { _runMsgHandler :: StateT MsgHandlerState (ReaderT BotConfig IO) a }
|
||||||
deriving ( Functor
|
deriving ( Functor
|
||||||
, Applicative
|
, Applicative
|
||||||
, Monad
|
, Monad
|
||||||
, MonadIO
|
, MonadIO
|
||||||
, MonadState MsgHandlerState
|
, MonadState MsgHandlerState
|
||||||
, MonadReader BotConfig)
|
, MonadReader BotConfig )
|
||||||
|
|
||||||
class ( MonadIO m, Applicative m
|
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
|
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)
|
runMsgHandler :: MsgHandler -> BotConfig -> MsgHandlerState -> Message -> IO (Maybe Command, MsgHandlerState)
|
||||||
runMsgHandler MsgHandler { .. } botConfig 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 -> IO MsgHandlerState
|
||||||
initMsgHandler MsgHandler { .. } botConfig =
|
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,
|
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,
|
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,
|
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,
|
exposed-modules: Network.IRC.Types, Network.IRC.Protocol,
|
||||||
Network.IRC.Handlers, Network.IRC.Client
|
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,
|
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,
|
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,
|
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.
|
-- Directories containing source files.
|
||||||
-- hs-source-dirs:
|
-- hs-source-dirs:
|
||||||
|
|
Loading…
Reference in New Issue