Added separate event processing loop

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
+        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
-            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
     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
+  lineChan    <- newChannel
-  commandChan <- newChan
+  commandChan <- newChannel
-  sendLatch   <- newEmptyMVar
+  eventChan   <- newChannel
-  readLatch   <- newEmptyMVar
   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 ()
+    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 ..."
   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)

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 :: 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
-  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

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 -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
-mkMsgHandler botConfig "messagelogger" = do
+mkMsgHandler botConfig _ "messagelogger" = do
   state <- liftIO $ newIORef Nothing
   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 { .. } = do

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 :: 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 }
             deriving (Show, Eq)

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)
+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 =
-  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 { msgHandlerRun  = const $ return Nothing
+newMsgHandler = MsgHandler {
-                           , msgHandlerStop = return () }
+  onMessage = const $ return Nothing,
+  onStop    = return (),
+  onEvent   = const $ return RespNothing
+}