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