abhin4v
/
hask-irc
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Added separate event processing loop

master
Abhinav Sarkar 2014-05-21 00:06:37 +05:30
parent a3e4b145ec
commit 2f6f968bc4
5 changed files with 113 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
Network/IRC/Client.hs
View File

@ -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)

16
Network/IRC/Handlers.hs
View File

@ -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
Network/IRC/Handlers/MessageLogger.hs
View File

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

7
Network/IRC/Handlers/SongSearch.hs
View File

@ -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)

59
Network/IRC/Types.hs
View File

@ -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
}