diff --git a/Network/IRC/Client.hs b/Network/IRC/Client.hs index 7481c2e..28a508b 100644 --- a/Network/IRC/Client.hs +++ b/Network/IRC/Client.hs @@ -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) diff --git a/Network/IRC/Handlers.hs b/Network/IRC/Handlers.hs index 71f8ab6..311893d 100644 --- a/Network/IRC/Handlers.hs +++ b/Network/IRC/Handlers.hs @@ -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 diff --git a/Network/IRC/Handlers/MessageLogger.hs b/Network/IRC/Handlers/MessageLogger.hs index 3db1506..ca60931 100644 --- a/Network/IRC/Handlers/MessageLogger.hs +++ b/Network/IRC/Handlers/MessageLogger.hs @@ -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 diff --git a/Network/IRC/Handlers/SongSearch.hs b/Network/IRC/Handlers/SongSearch.hs index 6d6d8f7..07d1c6b 100644 --- a/Network/IRC/Handlers/SongSearch.hs +++ b/Network/IRC/Handlers/SongSearch.hs @@ -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) diff --git a/Network/IRC/Types.hs b/Network/IRC/Types.hs index d11ddf5..60f2ae0 100644 --- a/Network/IRC/Types.hs +++ b/Network/IRC/Types.hs @@ -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 +}