Added separate event processing loop
parent
a3e4b145ec
commit
2f6f968bc4
|
@ -127,18 +127,39 @@ listenerLoop lineChan commandChan !idleFor = do
|
||||||
where
|
where
|
||||||
dispatchHandlers Bot { .. } message =
|
dispatchHandlers Bot { .. } message =
|
||||||
forM_ (mapToList msgHandlers) $ \(_, msgHandler) -> fork $
|
forM_ (mapToList msgHandlers) $ \(_, msgHandler) -> fork $
|
||||||
handle (\(e :: SomeException) -> debug $ "Exception! " ++ pack (show e)) $ do
|
handle (\(e :: SomeException) ->
|
||||||
mCmd <- runMsgHandler msgHandler botConfig message
|
debug $ "Exception while processing message: " ++ pack (show e)) $ do
|
||||||
|
mCmd <- handleMessage msgHandler botConfig message
|
||||||
case mCmd of
|
case mCmd of
|
||||||
Nothing -> return ()
|
Nothing -> return ()
|
||||||
Just (MessageCmd msg) -> sendMessage lineChan msg
|
Just cmd -> sendCommand commandChan cmd
|
||||||
Just cmd -> sendCommand commandChan cmd
|
|
||||||
|
|
||||||
loadMsgHandlers :: BotConfig -> IO (Map MsgHandlerName MsgHandler)
|
sendEvent :: Chan SomeEvent -> SomeEvent -> IO ()
|
||||||
loadMsgHandlers botConfig@BotConfig { .. } =
|
sendEvent = writeChan
|
||||||
|
|
||||||
|
eventProcessLoop :: EChannel SomeEvent -> Chan Line -> Chan Command -> Bot -> IO ()
|
||||||
|
eventProcessLoop (eventChan, latch) lineChan commandChan bot@Bot {.. } = do
|
||||||
|
event <- readChan eventChan
|
||||||
|
case fromEvent event of
|
||||||
|
Just (QuitEvent, _) -> latchIt latch
|
||||||
|
_ -> do
|
||||||
|
debug $ "** Event: " ++ pack (show event)
|
||||||
|
forM_ (mapToList msgHandlers) $ \(_, msgHandler) -> fork $
|
||||||
|
handle (\(ex :: SomeException) ->
|
||||||
|
debug $ "Exception while processing event: " ++ pack (show ex)) $ do
|
||||||
|
resp <- handleEvent msgHandler botConfig event
|
||||||
|
case resp of
|
||||||
|
RespMessage message -> sendMessage lineChan message
|
||||||
|
RespCommand command -> sendCommand commandChan command
|
||||||
|
RespEvent event' -> sendEvent eventChan event'
|
||||||
|
_ -> return ()
|
||||||
|
eventProcessLoop (eventChan, latch) lineChan commandChan bot
|
||||||
|
|
||||||
|
loadMsgHandlers :: BotConfig -> Chan SomeEvent -> IO (Map MsgHandlerName MsgHandler)
|
||||||
|
loadMsgHandlers botConfig@BotConfig { .. } eventChan =
|
||||||
flip (`foldM` mempty) msgHandlerNames $ \hMap msgHandlerName -> do
|
flip (`foldM` mempty) msgHandlerNames $ \hMap msgHandlerName -> do
|
||||||
debug $ "Loading msg handler: " ++ msgHandlerName
|
debug $ "Loading msg handler: " ++ msgHandlerName
|
||||||
mMsgHandler <- mkMsgHandler botConfig msgHandlerName
|
mMsgHandler <- mkMsgHandler botConfig eventChan 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 -> return $ insertMap msgHandlerName msgHandler hMap
|
Just msgHandler -> return $ insertMap msgHandlerName msgHandler hMap
|
||||||
|
@ -149,21 +170,21 @@ unloadMsgHandlers Bot { .. } =
|
||||||
debug $ "Unloading msg handler: " ++ msgHandlerName
|
debug $ "Unloading msg handler: " ++ msgHandlerName
|
||||||
stopMsgHandler msgHandler botConfig
|
stopMsgHandler msgHandler botConfig
|
||||||
|
|
||||||
connect :: BotConfig -> IO (Bot, MVar BotStatus, EChannel Line, EChannel Command)
|
connect :: BotConfig -> IO (Bot, MVar BotStatus, EChannel Line, EChannel Command, EChannel SomeEvent)
|
||||||
connect botConfig@BotConfig { .. } = do
|
connect botConfig@BotConfig { .. } = do
|
||||||
debug "Connecting ..."
|
debug "Connecting ..."
|
||||||
socket <- connectToWithRetry
|
socket <- connectToWithRetry
|
||||||
hSetBuffering socket LineBuffering
|
hSetBuffering socket LineBuffering
|
||||||
msgHandlers <- loadMsgHandlers botConfig
|
|
||||||
debug "Connected"
|
debug "Connected"
|
||||||
|
|
||||||
lineChan <- newChan
|
lineChan <- newChannel
|
||||||
commandChan <- newChan
|
commandChan <- newChannel
|
||||||
sendLatch <- newEmptyMVar
|
eventChan <- newChannel
|
||||||
readLatch <- newEmptyMVar
|
|
||||||
mvBotStatus <- newMVar Connected
|
mvBotStatus <- newMVar Connected
|
||||||
|
|
||||||
return (Bot botConfig socket msgHandlers, mvBotStatus, (lineChan, readLatch), (commandChan, sendLatch))
|
msgHandlers <- loadMsgHandlers botConfig (fst eventChan)
|
||||||
|
|
||||||
|
return (Bot botConfig socket msgHandlers, mvBotStatus, lineChan, commandChan, eventChan)
|
||||||
where
|
where
|
||||||
connectToWithRetry = connectTo (unpack server) (PortNumber (fromIntegral port))
|
connectToWithRetry = connectTo (unpack server) (PortNumber (fromIntegral port))
|
||||||
`catch` (\(e :: SomeException) -> do
|
`catch` (\(e :: SomeException) -> do
|
||||||
|
@ -171,13 +192,17 @@ connect botConfig@BotConfig { .. } = do
|
||||||
threadDelay (5 * oneSec)
|
threadDelay (5 * oneSec)
|
||||||
connectToWithRetry)
|
connectToWithRetry)
|
||||||
|
|
||||||
disconnect :: (Bot, MVar BotStatus, EChannel Line, EChannel Command) -> IO ()
|
newChannel = (,) <$> newChan <*> newEmptyMVar
|
||||||
disconnect (bot@Bot { .. }, mvBotStatus, (_, readLatch), (commandChan, sendLatch)) = do
|
|
||||||
|
disconnect :: (Bot, MVar BotStatus, EChannel Line, EChannel Command, EChannel SomeEvent) -> IO ()
|
||||||
|
disconnect (bot@Bot { .. }, mvBotStatus, (_, readLatch), (commandChan, sendLatch), (eventChan, eventLatch)) = do
|
||||||
debug "Disconnecting ..."
|
debug "Disconnecting ..."
|
||||||
sendCommand commandChan QuitCmd
|
sendCommand commandChan QuitCmd
|
||||||
awaitLatch sendLatch
|
awaitLatch sendLatch
|
||||||
swapMVar mvBotStatus Disconnected
|
swapMVar mvBotStatus Disconnected
|
||||||
awaitLatch readLatch
|
awaitLatch readLatch
|
||||||
|
sendEvent eventChan =<< toEvent QuitEvent
|
||||||
|
awaitLatch eventLatch
|
||||||
|
|
||||||
unloadMsgHandlers bot
|
unloadMsgHandlers bot
|
||||||
hClose socket
|
hClose socket
|
||||||
|
@ -195,9 +220,9 @@ run botConfig' = withSocketsDo $ do
|
||||||
status <- run_
|
status <- run_
|
||||||
case status of
|
case status of
|
||||||
Disconnected -> debug "Restarting .." >> run botConfig
|
Disconnected -> debug "Restarting .." >> run botConfig
|
||||||
|
Errored -> debug "Restarting .." >> run botConfig
|
||||||
Interrupted -> return ()
|
Interrupted -> return ()
|
||||||
NickNotAvailable -> return ()
|
NickNotAvailable -> return ()
|
||||||
Errored -> debug "Restarting .." >> run botConfig
|
|
||||||
_ -> error "Unsupported status"
|
_ -> error "Unsupported status"
|
||||||
where
|
where
|
||||||
botConfig = addCoreMsgHandlers botConfig'
|
botConfig = addCoreMsgHandlers botConfig'
|
||||||
|
@ -208,11 +233,12 @@ run botConfig' = withSocketsDo $ do
|
||||||
_ -> debug ("Exception! " ++ pack (show e)) >> return Errored
|
_ -> debug ("Exception! " ++ pack (show e)) >> return Errored
|
||||||
|
|
||||||
run_ = bracket (connect botConfig) disconnect $
|
run_ = bracket (connect botConfig) disconnect $
|
||||||
\(bot, mvBotStatus, (lineChan, readLatch), (commandChan, sendLatch)) ->
|
\(bot, mvBotStatus, (lineChan, readLatch), (commandChan, sendLatch), eventChannel) ->
|
||||||
handle handleErrors $ do
|
handle handleErrors $ do
|
||||||
sendCommand commandChan NickCmd
|
sendCommand commandChan NickCmd
|
||||||
sendCommand commandChan UserCmd
|
sendCommand commandChan UserCmd
|
||||||
|
|
||||||
fork $ sendCommandLoop (commandChan, sendLatch) bot
|
fork $ sendCommandLoop (commandChan, sendLatch) bot
|
||||||
fork $ readLineLoop mvBotStatus (lineChan, readLatch) bot oneSec
|
fork $ readLineLoop mvBotStatus (lineChan, readLatch) bot oneSec
|
||||||
|
fork $ eventProcessLoop eventChannel lineChan commandChan bot
|
||||||
runIRC bot Connected (listenerLoop lineChan commandChan 0)
|
runIRC bot Connected (listenerLoop lineChan commandChan 0)
|
||||||
|
|
|
@ -9,6 +9,7 @@ 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.Concurrent.Lifted
|
||||||
import Control.Monad.Reader.Class
|
import Control.Monad.Reader.Class
|
||||||
import Data.Convertible
|
import Data.Convertible
|
||||||
import Data.Text (strip)
|
import Data.Text (strip)
|
||||||
|
@ -22,19 +23,18 @@ clean = toLower . strip
|
||||||
coreMsgHandlerNames :: [Text]
|
coreMsgHandlerNames :: [Text]
|
||||||
coreMsgHandlerNames = ["pingpong", "messagelogger"]
|
coreMsgHandlerNames = ["pingpong", "messagelogger"]
|
||||||
|
|
||||||
mkMsgHandler :: BotConfig -> MsgHandlerName -> IO (Maybe MsgHandler)
|
mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
|
||||||
mkMsgHandler _ "greeter" = return . Just $ newMsgHandler { msgHandlerRun = greeter }
|
mkMsgHandler _ _ "greeter" = return . Just $ newMsgHandler { onMessage = greeter }
|
||||||
mkMsgHandler _ "welcomer" = return . Just $ newMsgHandler { msgHandlerRun = welcomer }
|
mkMsgHandler _ _ "welcomer" = return . Just $ newMsgHandler { onMessage = welcomer }
|
||||||
|
mkMsgHandler _ _ "pingpong" = do
|
||||||
mkMsgHandler _ "pingpong" = do
|
|
||||||
state <- getCurrentTime >>= newIORef
|
state <- getCurrentTime >>= newIORef
|
||||||
return . Just $ newMsgHandler { msgHandlerRun = pingPong state }
|
return . Just $ newMsgHandler { onMessage = pingPong state }
|
||||||
|
|
||||||
mkMsgHandler botConfig name =
|
mkMsgHandler botConfig eventChan name =
|
||||||
flip (`foldM` Nothing) [L.mkMsgHandler, SS.mkMsgHandler] $ \acc h ->
|
flip (`foldM` Nothing) [L.mkMsgHandler, SS.mkMsgHandler] $ \acc h ->
|
||||||
case acc of
|
case acc of
|
||||||
Just _ -> return acc
|
Just _ -> return acc
|
||||||
Nothing -> h botConfig name
|
Nothing -> h botConfig eventChan name
|
||||||
|
|
||||||
pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m (Maybe Command)
|
pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m (Maybe Command)
|
||||||
pingPong state PingMsg { .. } = do
|
pingPong state PingMsg { .. } = do
|
||||||
|
|
|
@ -11,6 +11,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 hiding (try, (</>), (<.>), FilePath, log)
|
import ClassyPrelude hiding (try, (</>), (<.>), FilePath, log)
|
||||||
|
import Control.Concurrent.Lifted
|
||||||
import Control.Exception.Lifted
|
import Control.Exception.Lifted
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Data.Time (diffDays)
|
import Data.Time (diffDays)
|
||||||
|
@ -22,13 +23,13 @@ import Network.IRC.Types
|
||||||
|
|
||||||
type LoggerState = Maybe (Handle, Day)
|
type LoggerState = Maybe (Handle, Day)
|
||||||
|
|
||||||
mkMsgHandler :: BotConfig -> MsgHandlerName -> IO (Maybe MsgHandler)
|
mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
|
||||||
mkMsgHandler botConfig "messagelogger" = do
|
mkMsgHandler botConfig _ "messagelogger" = do
|
||||||
state <- liftIO $ newIORef Nothing
|
state <- liftIO $ newIORef Nothing
|
||||||
initMessageLogger botConfig state
|
initMessageLogger botConfig state
|
||||||
return . Just $ newMsgHandler { msgHandlerRun = flip messageLogger state
|
return . Just $ newMsgHandler { onMessage = flip messageLogger state
|
||||||
, msgHandlerStop = exitMessageLogger state }
|
, onStop = exitMessageLogger state }
|
||||||
mkMsgHandler _ _ = return Nothing
|
mkMsgHandler _ _ _ = return Nothing
|
||||||
|
|
||||||
getLogFilePath :: BotConfig -> IO FilePath
|
getLogFilePath :: BotConfig -> IO FilePath
|
||||||
getLogFilePath BotConfig { .. } = do
|
getLogFilePath BotConfig { .. } = do
|
||||||
|
|
|
@ -9,6 +9,7 @@ module Network.IRC.Handlers.SongSearch (mkMsgHandler) where
|
||||||
import qualified Data.Configurator as CF
|
import qualified Data.Configurator as CF
|
||||||
|
|
||||||
import ClassyPrelude hiding (try)
|
import ClassyPrelude hiding (try)
|
||||||
|
import Control.Concurrent.Lifted
|
||||||
import Control.Exception.Lifted
|
import Control.Exception.Lifted
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
|
@ -19,9 +20,9 @@ import Network.HTTP.Base
|
||||||
|
|
||||||
import Network.IRC.Types
|
import Network.IRC.Types
|
||||||
|
|
||||||
mkMsgHandler :: BotConfig -> MsgHandlerName -> IO (Maybe MsgHandler)
|
mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
|
||||||
mkMsgHandler _ "songsearch" = return . Just $ newMsgHandler { msgHandlerRun = songSearch }
|
mkMsgHandler _ _ "songsearch" = return . Just $ newMsgHandler { onMessage = songSearch }
|
||||||
mkMsgHandler _ _ = return 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)
|
||||||
|
|
|
@ -1,3 +1,4 @@
|
||||||
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||||||
{-# LANGUAGE ExistentialQuantification #-}
|
{-# LANGUAGE ExistentialQuantification #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
@ -14,6 +15,10 @@ module Network.IRC.Types
|
||||||
, User (..)
|
, User (..)
|
||||||
, Message (..)
|
, Message (..)
|
||||||
, Command (..)
|
, Command (..)
|
||||||
|
, Event (..)
|
||||||
|
, SomeEvent
|
||||||
|
, QuitEvent(..)
|
||||||
|
, EventResponse (..)
|
||||||
, BotConfig (..)
|
, BotConfig (..)
|
||||||
, BotStatus (..)
|
, BotStatus (..)
|
||||||
, Bot (..)
|
, Bot (..)
|
||||||
|
@ -22,7 +27,8 @@ module Network.IRC.Types
|
||||||
, MsgHandler (..)
|
, MsgHandler (..)
|
||||||
, MonadMsgHandler
|
, MonadMsgHandler
|
||||||
, newMsgHandler
|
, newMsgHandler
|
||||||
, runMsgHandler
|
, handleMessage
|
||||||
|
, handleEvent
|
||||||
, stopMsgHandler)
|
, stopMsgHandler)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -30,6 +36,7 @@ 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.Typeable (cast)
|
||||||
|
|
||||||
type Channel = Text
|
type Channel = Text
|
||||||
type Nick = Text
|
type Nick = Text
|
||||||
|
@ -69,9 +76,32 @@ data Command =
|
||||||
| JoinCmd
|
| JoinCmd
|
||||||
| QuitCmd
|
| QuitCmd
|
||||||
| NamesCmd
|
| NamesCmd
|
||||||
| MessageCmd Message
|
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
class (Typeable e, Show e) => Event e where
|
||||||
|
toEvent :: e -> IO SomeEvent
|
||||||
|
toEvent e = SomeEvent <$> pure e <*> getCurrentTime
|
||||||
|
|
||||||
|
fromEvent :: SomeEvent -> Maybe (e, UTCTime)
|
||||||
|
fromEvent (SomeEvent e time) = do
|
||||||
|
ev <- cast e
|
||||||
|
return (ev, time)
|
||||||
|
|
||||||
|
data SomeEvent = forall e. Event e => SomeEvent e UTCTime deriving (Typeable)
|
||||||
|
|
||||||
|
instance Show SomeEvent where
|
||||||
|
show (SomeEvent e time) = formatTime defaultTimeLocale "[%F %T] " time ++ show e
|
||||||
|
|
||||||
|
data QuitEvent = QuitEvent deriving (Show, Typeable)
|
||||||
|
|
||||||
|
instance Event QuitEvent
|
||||||
|
|
||||||
|
data EventResponse = RespNothing
|
||||||
|
| RespEvent SomeEvent
|
||||||
|
| RespMessage Message
|
||||||
|
| RespCommand Command
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
data BotConfig = BotConfig { server :: !Text
|
data BotConfig = BotConfig { server :: !Text
|
||||||
, port :: !Int
|
, port :: !Int
|
||||||
, channel :: !Text
|
, channel :: !Text
|
||||||
|
@ -126,16 +156,27 @@ class (MonadIO m, Applicative m, MonadReader BotConfig m) => MonadMsgHandler m w
|
||||||
instance MonadMsgHandler MsgHandlerT where
|
instance MonadMsgHandler MsgHandlerT where
|
||||||
msgHandler = id
|
msgHandler = id
|
||||||
|
|
||||||
runMsgHandler :: MsgHandler -> BotConfig -> Message -> IO (Maybe Command)
|
handleMessage :: MsgHandler -> BotConfig -> Message -> IO (Maybe Command)
|
||||||
runMsgHandler MsgHandler { .. } botConfig = flip runReaderT botConfig . _runMsgHandler . msgHandlerRun
|
handleMessage MsgHandler { .. } botConfig =
|
||||||
|
flip runReaderT botConfig . _runMsgHandler . onMessage
|
||||||
|
|
||||||
stopMsgHandler :: MsgHandler -> BotConfig -> IO ()
|
stopMsgHandler :: MsgHandler -> BotConfig -> IO ()
|
||||||
stopMsgHandler MsgHandler { .. } botConfig =
|
stopMsgHandler MsgHandler { .. } botConfig =
|
||||||
flip runReaderT botConfig . _runMsgHandler $ msgHandlerStop
|
flip runReaderT botConfig . _runMsgHandler $ onStop
|
||||||
|
|
||||||
data MsgHandler = MsgHandler { msgHandlerRun :: !(forall m . MonadMsgHandler m => Message -> m (Maybe Command))
|
handleEvent :: MsgHandler -> BotConfig -> SomeEvent -> IO EventResponse
|
||||||
, msgHandlerStop :: !(forall m . MonadMsgHandler m => m ()) }
|
handleEvent MsgHandler { .. } botConfig =
|
||||||
|
flip runReaderT botConfig . _runMsgHandler . onEvent
|
||||||
|
|
||||||
|
data MsgHandler = MsgHandler {
|
||||||
|
onMessage :: !(forall m . MonadMsgHandler m => Message -> m (Maybe Command)),
|
||||||
|
onStop :: !(forall m . MonadMsgHandler m => m ()),
|
||||||
|
onEvent :: !(forall m . MonadMsgHandler m => SomeEvent -> m EventResponse)
|
||||||
|
}
|
||||||
|
|
||||||
newMsgHandler :: MsgHandler
|
newMsgHandler :: MsgHandler
|
||||||
newMsgHandler = MsgHandler { msgHandlerRun = const $ return Nothing
|
newMsgHandler = MsgHandler {
|
||||||
, msgHandlerStop = return () }
|
onMessage = const $ return Nothing,
|
||||||
|
onStop = return (),
|
||||||
|
onEvent = const $ return RespNothing
|
||||||
|
}
|
||||||
|
|
Loading…
Reference in New Issue