From 757285f4fdea01f01ba77a13e1fdddfb4a4e04a4 Mon Sep 17 00:00:00 2001 From: Abhinav Sarkar Date: Sat, 4 Oct 2014 21:22:24 +0530 Subject: [PATCH] Major refactoring 1. Unified Messages, Events and Commands 2. Switched to a single TChan based message bus for communication between modules 3. Each handler now has a dedicated thread in which it runs, ensuring sequentiality of messages --- hask-irc-core/Network/IRC.hs | 21 ++- hask-irc-core/Network/IRC/Bot.hs | 136 ++++++------------ hask-irc-core/Network/IRC/Client.hs | 133 ++++++++++------- hask-irc-core/Network/IRC/Handlers/Core.hs | 60 ++++---- .../Network/IRC/Internal/Command/Types.hs | 67 --------- .../Network/IRC/Internal/Event/Types.hs | 57 -------- hask-irc-core/Network/IRC/Internal/Types.hs | 115 +++++++-------- .../IRC/{Internal => }/Message/Types.hs | 75 +++++++--- hask-irc-core/Network/IRC/MessageBus.hs | 58 ++++++++ hask-irc-core/Network/IRC/Protocol.hs | 44 +++--- hask-irc-core/Network/IRC/Types.hs | 16 +-- hask-irc-core/Network/IRC/Util.hs | 57 +++----- hask-irc-core/hask-irc-core.cabal | 10 +- hask-irc-handlers/Network/IRC/Handlers.hs | 1 + .../Network/IRC/Handlers/Auth.hs | 41 +++--- .../Network/IRC/Handlers/Auth/Types.hs | 13 +- .../Network/IRC/Handlers/Greet.hs | 33 +++-- .../Network/IRC/Handlers/MessageLogger.hs | 20 +-- .../Network/IRC/Handlers/NickTracker.hs | 59 ++++---- .../Handlers/NickTracker/Internal/Types.hs | 36 ++--- .../Network/IRC/Handlers/SongSearch.hs | 18 +-- .../Network/IRC/Handlers/Tell.hs | 66 ++++----- .../IRC/Handlers/Tell/Internal/Types.hs | 38 ++--- hask-irc-runner/Main.hs | 2 +- hask-irc-runner/Network/IRC/Config.hs | 12 +- 25 files changed, 563 insertions(+), 625 deletions(-) delete mode 100644 hask-irc-core/Network/IRC/Internal/Command/Types.hs delete mode 100644 hask-irc-core/Network/IRC/Internal/Event/Types.hs rename hask-irc-core/Network/IRC/{Internal => }/Message/Types.hs (64%) create mode 100644 hask-irc-core/Network/IRC/MessageBus.hs diff --git a/hask-irc-core/Network/IRC.hs b/hask-irc-core/Network/IRC.hs index 0c5177b..ac54d42 100644 --- a/hask-irc-core/Network/IRC.hs +++ b/hask-irc-core/Network/IRC.hs @@ -1,8 +1,15 @@ -module Network.IRC - ( - module Network.IRC.Types, - module Network.IRC.Client - )where +{-| +Module : Network.IRC +Description : A simple and extensible IRC bot. +Copyright : (c) Abhinav Sarkar, 2014 +License : Apache-2.0 +Maintainer : abhinav@abhinavsarkar.net +Stability : experimental +Portability : POSIX +-} -import Network.IRC.Types -import Network.IRC.Client +module Network.IRC (module IRC) where + +import Network.IRC.Types as IRC +import Network.IRC.Client as IRC +import Network.IRC.MessageBus as IRC diff --git a/hask-irc-core/Network/IRC/Bot.hs b/hask-irc-core/Network/IRC/Bot.hs index 08f5b39..1c852e7 100644 --- a/hask-irc-core/Network/IRC/Bot.hs +++ b/hask-irc-core/Network/IRC/Bot.hs @@ -1,22 +1,17 @@ {-# LANGUAGE TemplateHaskell #-} module Network.IRC.Bot - ( Line - , sendCommand - , sendMessage - , sendEvent - , readLine + ( In , sendCommandLoop - , readLineLoop - , messageProcessLoop - , eventProcessLoop ) + , readMessageLoop + , messageProcessLoop ) where import qualified Data.Text.Format as TF import qualified System.Log.Logger as HSL import ClassyPrelude -import Control.Concurrent.Lifted (fork, Chan, readChan, writeChan, threadDelay) +import Control.Concurrent.Lifted (threadDelay) import Control.Exception.Lifted (mask_, mask) import Control.Monad.Reader (ask) import Control.Monad.State (get, put) @@ -25,145 +20,108 @@ import System.IO (hIsEOF) import System.Timeout (timeout) import System.Log.Logger.TH (deriveLoggers) +import Network.IRC.MessageBus import Network.IRC.Internal.Types import Network.IRC.Protocol import Network.IRC.Types import Network.IRC.Util -$(deriveLoggers "HSL" [HSL.DEBUG, HSL.INFO, HSL.ERROR]) +$(deriveLoggers "HSL" [HSL.INFO, HSL.ERROR]) -data Line = Timeout | EOF | Line !UTCTime !Text | Msg FullMessage deriving (Show, Eq) +data RawIn = Line !UTCTime !Text | EOS deriving (Show, Eq) +data In = Timeout | EOD | Msg Message deriving (Show, Eq) -sendCommand :: Chan Command -> Command -> IO () -sendCommand = writeChan - -sendMessage :: Chan Line -> FullMessage -> IO () -sendMessage = (. Msg) . writeChan - -sendEvent :: Chan Event -> Event -> IO () -sendEvent = writeChan - -readLine :: Chan Line -> IO Line -readLine = readChan - -sendCommandLoop :: Channel Command -> Bot -> IO () -sendCommandLoop (commandChan, latch) bot@Bot { .. } = do - cmd <- readChan commandChan - let mline = formatCommand botConfig cmd +sendCommandLoop :: MessageChannel Message -> Bot -> IO () +sendCommandLoop commandChan bot@Bot { .. } = do + msg@(Message _ _ cmd) <- receiveMessage commandChan + let mline = formatCommand botConfig msg handle (\(e :: SomeException) -> - errorM ("Error while writing to connection: " ++ show e) >> latchIt latch) $ do + errorM ("Error while writing to connection: " ++ show e) >> closeMessageChannel commandChan) $ do whenJust mline $ \line -> do TF.hprint botSocket "{}\r\n" $ TF.Only line infoM . unpack $ "> " ++ line - case fromCommand cmd of - Just QuitCmd -> latchIt latch - _ -> sendCommandLoop (commandChan, latch) bot + case fromMessage cmd of + Just QuitCmd -> closeMessageChannel commandChan + _ -> sendCommandLoop commandChan bot -readLineLoop :: MVar BotStatus -> Channel Line -> Bot -> Int -> IO () -readLineLoop = go [] +readMessageLoop :: MVar BotStatus -> MessageChannel In -> Bot -> Int -> IO () +readMessageLoop = go [] where msgPartTimeout = 10 - go !msgParts mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do + go !msgParts mvBotStatus inChan bot@Bot { .. } timeoutDelay = do botStatus <- readMVar mvBotStatus case botStatus of - Disconnected -> latchIt latch + Disconnected -> closeMessageChannel inChan _ -> do mLine <- try $ timeout timeoutDelay readLine' msgParts' <- case mLine of Left (e :: SomeException) -> do errorM $ "Error while reading from connection: " ++ show e - writeChan lineChan EOF >> return msgParts - Right Nothing -> writeChan lineChan Timeout >> return msgParts + sendMessage inChan EOD >> return msgParts + Right Nothing -> sendMessage inChan Timeout >> return msgParts Right (Just (Line time line)) -> do let (mmsg, msgParts') = parseLine botConfig time line msgParts - whenJust mmsg $ writeChan lineChan . Msg + whenJust mmsg $ sendMessage inChan . Msg return msgParts' - Right (Just l) -> writeChan lineChan l >> return msgParts + Right (Just EOS) -> sendMessage inChan EOD >> return msgParts limit <- map (addUTCTime (- msgPartTimeout)) getCurrentTime let msgParts'' = concat . filter ((> limit) . msgPartTime . headEx . sortBy (flip $ comparing msgPartTime)) . groupAllOn (msgPartParserId &&& msgPartTarget) $ msgParts' - go msgParts'' mvBotStatus (lineChan, latch) bot timeoutDelay + go msgParts'' mvBotStatus inChan bot timeoutDelay where readLine' = do eof <- hIsEOF botSocket if eof - then return EOF + then return EOS else mask $ \unmask -> do line <- map initEx . unmask $ hGetLine botSocket infoM . unpack $ "< " ++ line now <- getCurrentTime return $ Line now line -messageProcessLoop :: Chan Line -> Chan Command -> IRC () +messageProcessLoop :: MessageChannel In -> MessageChannel Message -> IRC () messageProcessLoop = go 0 where - go !idleFor lineChan commandChan = do - status <- get - bot@Bot { .. } <- ask - let nick = botNick botConfig + go !idleFor inChan messageChan = do + status <- get + Bot { .. } <- ask + let nick = botNick botConfig nStatus <- io . mask_ $ if idleFor >= (oneSec * botTimeout botConfig) then infoM "Timeout" >> return Disconnected else do when (status == Kicked) $ - threadDelay (5 * oneSec) >> sendCommand commandChan (toCommand JoinCmd) + threadDelay (5 * oneSec) >> newMessage JoinCmd >>= sendMessage messageChan - mLine <- readLine lineChan - case mLine of - Timeout -> do - now <- getCurrentTime - dispatchHandlers bot (FullMessage now "" $ toMessage IdleMsg) >> return Idle - EOF -> infoM "Connection closed" >> return Disconnected - Line _ _ -> error "This should never happen" - Msg (msg@FullMessage { .. }) -> do + mIn <- receiveMessage inChan + case mIn of + Timeout -> newMessage IdleMsg >>= sendMessage messageChan >> return Idle + EOD -> infoM "Connection closed" >> return Disconnected + Msg (msg@Message { .. }) -> do nStatus <- handleMsg nick message - dispatchHandlers bot msg + sendMessage messageChan msg return nStatus put nStatus case nStatus of - Idle -> go (idleFor + oneSec) lineChan commandChan + Idle -> go (idleFor + oneSec) inChan messageChan Disconnected -> return () NickNotAvailable -> return () - _ -> go 0 lineChan commandChan + _ -> go 0 inChan messageChan where - dispatchHandlers Bot { .. } message = - forM_ (mapValues msgHandlers) $ \msgHandler -> void . fork $ - handle (\(e :: SomeException) -> - errorM $ "Exception while processing message: " ++ show e) $ do - cmds <- handleMessage msgHandler botConfig message - forM_ cmds (sendCommand commandChan) - handleMsg nick message | Just (JoinMsg user) <- fromMessage message, userNick user == nick = infoM "Joined" >> return Joined - | Just (KickMsg { .. }) <- fromMessage message, kickedNick == nick = + | Just (KickMsg { .. }) <- fromMessage message, kickedNick == nick = infoM "Kicked" >> return Kicked - | Just NickInUseMsg <- fromMessage message = - infoM "Nick already in use" >> return NickNotAvailable - | Just (ModeMsg { .. }) <- fromMessage message, modeUser == Self = - sendCommand commandChan (toCommand JoinCmd) >> return Connected - | otherwise = return Connected - -eventProcessLoop :: Channel Event -> 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 - debugM $ "Event: " ++ show event - forM_ (mapValues msgHandlers) $ \msgHandler -> void . fork $ - handle (\(ex :: SomeException) -> - errorM $ "Exception while processing event: " ++ show ex) $ do - resp <- handleEvent msgHandler botConfig event - case resp of - RespMessage messages -> forM_ messages $ sendMessage lineChan - RespCommand commands -> forM_ commands $ sendCommand commandChan - RespEvent events -> forM_ events $ sendEvent eventChan - _ -> return () - eventProcessLoop (eventChan, latch) lineChan commandChan bot + | Just NickInUseMsg <- fromMessage message = + infoM "Nick already in use" >> return NickNotAvailable + | Just (ModeMsg { .. }) <- fromMessage message, modeUser == Self = + newMessage JoinCmd >>= sendMessage messageChan >> return Connected + | otherwise = + return Connected diff --git a/hask-irc-core/Network/IRC/Client.hs b/hask-irc-core/Network/IRC/Client.hs index 6664899..ba37ba4 100644 --- a/hask-irc-core/Network/IRC/Client.hs +++ b/hask-irc-core/Network/IRC/Client.hs @@ -15,7 +15,7 @@ module Network.IRC.Client (runBot) where import qualified System.Log.Logger as HSL import ClassyPrelude -import Control.Concurrent.Lifted (fork, newChan, threadDelay, myThreadId, Chan) +import Control.Concurrent.Lifted (fork, threadDelay, myThreadId) import Control.Exception.Lifted (throwTo, AsyncException (UserInterrupt)) import Network (PortID (PortNumber), connectTo, withSocketsDo) import System.IO (hSetBuffering, BufferMode(..)) @@ -27,93 +27,103 @@ import System.Log.Logger (Priority (..), updateGlobalLogger, rootLoggerN import System.Log.Logger.TH (deriveLoggers) import System.Posix.Signals (installHandler, sigINT, sigTERM, Handler (Catch)) -import qualified Network.IRC.Handlers.Core as Core - import Network.IRC.Bot import Network.IRC.Internal.Types +import Network.IRC.MessageBus import Network.IRC.Types +import Network.IRC.Handlers.Core import Network.IRC.Util $(deriveLoggers "HSL" [HSL.DEBUG, HSL.ERROR]) -coreMsgHandlerNames :: [MsgHandlerName] -coreMsgHandlerNames = ["pingpong", "help"] +data ConnectionResource = ConnectionResource + { bot :: Bot + , botStatus :: MVar BotStatus + , inChannel :: MessageChannel In + , mainMsgChannel :: MessageChannel Message + , cmdMsgChannel :: MessageChannel Message + , handlerMsgChannels :: [MessageChannel Message] + } -connect :: BotConfig -> IO (Bot, MVar BotStatus, Channel Line, Channel Command, Channel Event) +connect :: BotConfig -> IO ConnectionResource connect botConfig@BotConfig { .. } = do debugM "Connecting ..." socket <- connectToWithRetry hSetBuffering socket LineBuffering debugM "Connected" - lineChan <- newChannel - commandChan <- newChannel - eventChan <- newChannel - mvBotStatus <- newMVar Connected - msgHandlers <- loadMsgHandlers (fst eventChan) - msgHandlerInfo' <- foldM (\m (hn, h) -> getHelp h botConfig >>= \hm -> return $ insertMap hn hm m) - mempty (mapToList msgHandlers) - let botConfig' = botConfig { msgHandlerInfo = msgHandlerInfo'} - return (Bot botConfig' socket msgHandlers, mvBotStatus, lineChan, commandChan, eventChan) + messageBus <- newMessageBus + inBus <- newMessageBus + mvBotStatus <- newMVar Connected + + inChannel <- newMessageChannel inBus + mainMsgChannel <- newMessageChannel messageBus + cmdMsgChannel <- newMessageChannel messageBus + + msgHandlersChans <- loadMsgHandlers messageBus + msgHandlerInfo' <- foldM (\m (hn, (h, _)) -> getHelp h botConfig >>= \hm -> return $ insertMap hn hm m) + mempty (mapToList msgHandlersChans) + + let botConfig' = botConfig { msgHandlerInfo = msgHandlerInfo'} + let msgHandlerChannels = map snd (mapValues msgHandlersChans) + let msgHandlers = map fst msgHandlersChans + + return $ ConnectionResource + (Bot botConfig' socket msgHandlers) mvBotStatus + inChannel mainMsgChannel cmdMsgChannel msgHandlerChannels where - connectToWithRetry = connectTo (unpack server) (PortNumber (fromIntegral port)) + connectToWithRetry = connectTo (unpack botServer) (PortNumber (fromIntegral botPort)) `catch` (\(e :: SomeException) -> do errorM ("Error while connecting: " ++ show e ++ ". Waiting.") threadDelay (5 * oneSec) connectToWithRetry) - newChannel = (,) <$> newChan <*> newEmptyMVar + mkMsgHandler name messageBus = + case lookup name msgHandlerMakers of + Nothing -> return Nothing + Just maker -> do + messageChannel <- newMessageChannel messageBus + handler <- msgHandlerMaker maker botConfig messageChannel + return $ Just (handler, messageChannel) - mkMsgHandler :: Chan Event -> MsgHandlerName -> IO (Maybe MsgHandler) - mkMsgHandler eventChan name = - flip (`foldM` Nothing) msgHandlerMakers $ \finalHandler handler -> - case finalHandler of - Just _ -> return finalHandler - Nothing -> msgHandlerMaker handler botConfig eventChan name - - loadMsgHandlers eventChan = + loadMsgHandlers messageBus = flip (`foldM` mempty) (mapKeys msgHandlerInfo) $ \hMap msgHandlerName -> do debugM . unpack $ "Loading msg handler: " ++ msgHandlerName - mMsgHandler <- mkMsgHandler eventChan msgHandlerName + mMsgHandler <- mkMsgHandler msgHandlerName messageBus case mMsgHandler of - Nothing -> do + Nothing -> do debugM . unpack $ "No msg handler found with name: " ++ msgHandlerName return hMap - Just msgHandler -> return $ insertMap msgHandlerName msgHandler hMap + Just msgHandlerAndChannel -> return $ insertMap msgHandlerName msgHandlerAndChannel hMap -disconnect :: (Bot, MVar BotStatus, Channel Line, Channel Command, Channel Event) -> IO () -disconnect (Bot { .. }, mvBotStatus, (_, readLatch), (commandChan, sendLatch), (eventChan, eventLatch)) = do +disconnect :: ConnectionResource -> IO () +disconnect ConnectionResource { bot = Bot { .. }, .. } = do debugM "Disconnecting ..." - sendCommand commandChan $ toCommand QuitCmd - awaitLatch sendLatch - swapMVar mvBotStatus Disconnected - awaitLatch readLatch - sendEvent eventChan =<< toEvent QuitEvent - awaitLatch eventLatch + sendMessage cmdMsgChannel =<< newMessage QuitCmd + awaitMessageChannel cmdMsgChannel - unloadMsgHandlers + swapMVar botStatus Disconnected + awaitMessageChannel inChannel + + forM_ handlerMsgChannels awaitMessageChannel handle (\(_ :: SomeException) -> return ()) $ hClose botSocket debugM "Disconnected" - where - unloadMsgHandlers = forM_ (mapToList msgHandlers) $ \(msgHandlerName, msgHandler) -> do - debugM . unpack $ "Unloading msg handler: " ++ msgHandlerName - stopMsgHandler msgHandler botConfig runBotIntenal :: BotConfig -> IO () runBotIntenal botConfig' = withSocketsDo $ do status <- run case status of - Disconnected -> debugM "Restarting .." >> runBotIntenal botConfig - Errored -> debugM "Restarting .." >> runBotIntenal botConfig + Disconnected -> debugM "Restarting .." >> runBotIntenal botConfigWithCore + Errored -> debugM "Restarting .." >> runBotIntenal botConfigWithCore Interrupted -> return () NickNotAvailable -> return () _ -> error "Unsupported status" where - botConfig = botConfig' { + botConfigWithCore = botConfig' { msgHandlerInfo = foldl' (\m name -> insertMap name mempty m) mempty - (hashNub $ mapKeys (msgHandlerInfo botConfig') ++ coreMsgHandlerNames), - msgHandlerMakers = ordNub $ Core.mkMsgHandler : msgHandlerMakers botConfig' + (hashNub $ mapKeys (msgHandlerInfo botConfig') ++ mapKeys coreMsgHandlerMakers), + msgHandlerMakers = coreMsgHandlerMakers <> msgHandlerMakers botConfig' } handleErrors :: SomeException -> IO BotStatus @@ -121,18 +131,33 @@ runBotIntenal botConfig' = withSocketsDo $ do Just UserInterrupt -> debugM "User interrupt" >> return Interrupted _ -> debugM ("Exception! " ++ show e) >> return Errored - run = bracket (connect botConfig) disconnect $ - \(bot, mvBotStatus, (lineChan, readLatch), (commandChan, sendLatch), eventChannel) -> + runHandler botConfig ((msgHandlerName, handler), msgChannel) = receiveMessage msgChannel >>= go + where + go msg@Message { .. } + | Just QuitCmd <- fromMessage message = do + debugM . unpack $ "Stopping msg handler: " ++ msgHandlerName + stopMsgHandler handler botConfig + closeMessageChannel msgChannel + return () + | otherwise = do + resps <- handleMessage handler botConfig msg + forM_ resps $ sendMessage msgChannel + runHandler botConfig ((msgHandlerName, handler), msgChannel) + + run = bracket (connect botConfigWithCore) disconnect $ + \ConnectionResource { .. } -> handle handleErrors $ do + let Bot { .. } = bot debugM $ "Running with config:\n" ++ show botConfig - sendCommand commandChan $ toCommand NickCmd - sendCommand commandChan $ toCommand UserCmd + sendMessage cmdMsgChannel =<< newMessage NickCmd + sendMessage cmdMsgChannel =<< newMessage UserCmd - fork $ sendCommandLoop (commandChan, sendLatch) bot - fork $ readLineLoop mvBotStatus (lineChan, readLatch) bot oneSec - fork $ eventProcessLoop eventChannel lineChan commandChan bot - runIRC bot Connected (messageProcessLoop lineChan commandChan) + fork $ sendCommandLoop cmdMsgChannel bot + fork $ readMessageLoop botStatus inChannel bot oneSec + forM_ (zip (mapToList msgHandlers) handlerMsgChannels) $ + void . fork . runHandler botConfig + runIRC bot Connected (messageProcessLoop inChannel mainMsgChannel) -- | Creates and runs an IRC bot for given the config. This IO action runs forever. runBot :: BotConfig -- ^ The bot config used to create the bot. diff --git a/hask-irc-core/Network/IRC/Handlers/Core.hs b/hask-irc-core/Network/IRC/Handlers/Core.hs index 7fb65c2..23b24f8 100644 --- a/hask-irc-core/Network/IRC/Handlers/Core.hs +++ b/hask-irc-core/Network/IRC/Handlers/Core.hs @@ -1,50 +1,57 @@ -module Network.IRC.Handlers.Core (mkMsgHandler) where +module Network.IRC.Handlers.Core (coreMsgHandlerMakers) where import ClassyPrelude -import Control.Monad.Reader (ask) -import Data.Convertible (convert) -import Data.Time (addUTCTime) +import Control.Monad.Reader (ask) +import Data.Convertible (convert) +import Data.Time (addUTCTime) import Network.IRC.Types import Network.IRC.Util -mkMsgHandler :: MsgHandlerMaker -mkMsgHandler = MsgHandlerMaker "core" go - where - go _ _ "pingpong" = do - state <- getCurrentTime >>= newIORef - return . Just $ newMsgHandler { onMessage = pingPong state } - go _ _ "help" = - return . Just $ newMsgHandler { onMessage = help, - onHelp = return $ singletonMap "!help" helpMsg } - go _ _ _ = return Nothing +coreMsgHandlerMakers :: Map MsgHandlerName MsgHandlerMaker +coreMsgHandlerMakers = mapFromList [ + ("pingpong", pingPongMsgHandlerMaker) + , ("help", helpMsgHandlerMaker) + ] +pingPongMsgHandlerMaker :: MsgHandlerMaker +pingPongMsgHandlerMaker = MsgHandlerMaker "pingpong" go + where + go _ _ = do + state <- io $ getCurrentTime >>= newIORef + return $ newMsgHandler { onMessage = pingPong state } + +helpMsgHandlerMaker :: MsgHandlerMaker +helpMsgHandlerMaker = MsgHandlerMaker "help" go + where + go _ _ = return $ newMsgHandler { onMessage = help + , handlerHelp = return $ singletonMap "!help" helpMsg } helpMsg = "Get help. !help or !help " -pingPong :: MonadMsgHandler m => IORef UTCTime -> FullMessage -> m [Command] -pingPong state FullMessage { .. } +pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m [Message] +pingPong state Message { .. } | Just (PingMsg msg) <- fromMessage message = - io (atomicWriteIORef state msgTime) >> return [toCommand $ PongCmd msg] + io (atomicWriteIORef state msgTime) >> map singleton (newMessage . PongCmd $ msg) | Just (PongMsg _) <- fromMessage message = io (atomicWriteIORef state msgTime) >> return [] | Just IdleMsg <- fromMessage message , even (convert msgTime :: Int) = do BotConfig { .. } <- ask let limit = fromIntegral $ botTimeout `div` 2 - io $ do - lastComm <- readIORef state - return [toCommand . PingCmd . pack . formatTime defaultTimeLocale "%s" $ msgTime - | addUTCTime limit lastComm < msgTime] + lastComm <- io $ readIORef state + if addUTCTime limit lastComm < msgTime + then map singleton . newMessage . PingCmd . pack . formatTime defaultTimeLocale "%s" $ msgTime + else return [] | otherwise = return [] -help :: MonadMsgHandler m => FullMessage -> m [Command] -help FullMessage { .. } = case fromMessage message of +help :: MonadMsgHandler m => Message -> m [Message] +help Message { .. } = case fromMessage message of Just (ChannelMsg _ msg) | "!help" == clean msg -> do BotConfig { .. } <- ask let commands = concatMap mapKeys . mapValues $ msgHandlerInfo - return . map (toCommand . ChannelMsgReply) $ - [ "I know these commands: " ++ unwords commands + mapM (newMessage . ChannelMsgReply) [ + "I know these commands: " ++ unwords commands , "Type !help to know more about any command" ] | "!help" `isPrefixOf` msg -> do @@ -52,5 +59,6 @@ help FullMessage { .. } = case fromMessage message of let command = dropWhile (== '!') . clean . unwords . drop 1 . words $ msg let mHelp = find ((\c -> c == command || c == cons '!' command) . fst) . concatMap mapToList . mapValues $ msgHandlerInfo - return [toCommand . ChannelMsgReply $ maybe ("No such command found: " ++ command) snd mHelp] + map singleton . newMessage . ChannelMsgReply + $ maybe ("No such command found: " ++ command) snd mHelp _ -> return [] diff --git a/hask-irc-core/Network/IRC/Internal/Command/Types.hs b/hask-irc-core/Network/IRC/Internal/Command/Types.hs deleted file mode 100644 index 4e96708..0000000 --- a/hask-irc-core/Network/IRC/Internal/Command/Types.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} - -module Network.IRC.Internal.Command.Types where - -import ClassyPrelude -import Data.Typeable (cast) - -import Network.IRC.Internal.Message.Types - --- | The typeclass for IRC commands sent from the bot to the server. -class (Typeable cmd, Show cmd, Eq cmd, Ord cmd) => CommandC cmd where - toCommand :: cmd -> Command - toCommand = Command - - fromCommand :: Command -> Maybe cmd - fromCommand (Command cmd) = cast cmd - --- | A wrapper over all types of IRC commands. -data Command = forall m . CommandC m => Command m deriving (Typeable) - -instance Show Command where - show (Command m) = show m - -instance Eq Command where - Command m1 == Command m2 = case cast m1 of - Just m1' -> m1' == m2 - _ -> False - --- | A /PING/ command. A 'PongMsg' is expected as a response to this. -data PingCmd = PingCmd !Text deriving (Typeable, Show, Eq, Ord) -instance CommandC PingCmd - --- | A /PONG/ command. Sent in response to a 'PingMsg'. -data PongCmd = PongCmd !Text deriving (Typeable, Show, Eq, Ord) -instance CommandC PongCmd - --- | A /PRIVMSG/ message sent to the channel. -data ChannelMsgReply = ChannelMsgReply !Text deriving (Typeable, Show, Eq, Ord) -instance CommandC ChannelMsgReply - --- | A /PRIVMSG/ message sent to a user. -data PrivMsgReply = PrivMsgReply !User !Text deriving (Typeable, Show, Eq, Ord) -instance CommandC PrivMsgReply - --- | A /NICK/ command sent to set the bot's nick. -data NickCmd = NickCmd deriving (Typeable, Show, Eq, Ord) -instance CommandC NickCmd - --- | A /USER/ command sent to identify the bot. -data UserCmd = UserCmd deriving (Typeable, Show, Eq, Ord) -instance CommandC UserCmd - --- | A /JOIN/ command sent to join the channel. -data JoinCmd = JoinCmd deriving (Typeable, Show, Eq, Ord) -instance CommandC JoinCmd - --- | A /QUIT/ command sent to quit the server. -data QuitCmd = QuitCmd deriving (Typeable, Show, Eq, Ord) -instance CommandC QuitCmd - --- | A /NAMES/ command sent to ask for the nicks of the users in the channel. -data NamesCmd = NamesCmd deriving (Typeable, Show, Eq, Ord) -instance CommandC NamesCmd diff --git a/hask-irc-core/Network/IRC/Internal/Event/Types.hs b/hask-irc-core/Network/IRC/Internal/Event/Types.hs deleted file mode 100644 index 7d1b026..0000000 --- a/hask-irc-core/Network/IRC/Internal/Event/Types.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} - -module Network.IRC.Internal.Event.Types where - -import ClassyPrelude -import Data.Typeable (cast) - -import Network.IRC.Internal.Message.Types -import Network.IRC.Internal.Command.Types - --- ** Events - --- | Events are used for communication between message handlers. To send events, write them to the --- event channel provided to the 'MsgHandler' when it is created. To receive events, provide --- an 'onEvent' function as a part of the message handler. -class (Typeable e, Show e, Eq e) => EventC e where - -- | Creates an event. - toEvent :: e -> IO Event - toEvent e = Event <$> pure e <*> getCurrentTime - - -- | Extracts a received event. - fromEvent :: Event -> Maybe (e, UTCTime) - fromEvent (Event e time) = do - ev <- cast e - return (ev, time) - --- | A wrapper over all types of 'Event's to allow sending them over channel of same type. -data Event = forall e. (EventC e, Typeable e) => Event e UTCTime deriving (Typeable) - -instance Show Event where - show (Event e time) = formatTime defaultTimeLocale "[%F %T] " time ++ show e - -instance Eq Event where - Event e1 t1 == Event e2 t2 = - case cast e2 of - Just e2' -> e1 == e2' && t1 == t2 - Nothing -> False - --- | Response to an event received by a message handler. -data EventResponse = - -- | No response - RespNothing - -- | Events as the response. They will be sent to all message handlers like usual events. - | RespEvent [Event] - -- | Messages as the response. They will be sent to all message handlers like usual messages. - | RespMessage [FullMessage] - -- | Commands as the response. They will be sent to the server like usual commands. - | RespCommand [Command] - deriving (Show, Eq) - --- | An event signifying the bot quitting the server. -data QuitEvent = QuitEvent deriving (Show, Eq, Ord, Typeable) -instance EventC QuitEvent diff --git a/hask-irc-core/Network/IRC/Internal/Types.hs b/hask-irc-core/Network/IRC/Internal/Types.hs index 329ee22..8395afa 100644 --- a/hask-irc-core/Network/IRC/Internal/Types.hs +++ b/hask-irc-core/Network/IRC/Internal/Types.hs @@ -8,15 +8,13 @@ module Network.IRC.Internal.Types where import qualified Data.Configurator as CF import ClassyPrelude -import Control.Concurrent.Lifted (Chan) -import Control.Monad.Base (MonadBase) -import Control.Monad.Reader (ReaderT, MonadReader, runReaderT) -import Control.Monad.State (StateT, MonadState, execStateT) -import Data.Configurator.Types (Config) +import Control.Monad.Base (MonadBase) +import Control.Monad.Reader (ReaderT, MonadReader, runReaderT) +import Control.Monad.State (StateT, MonadState, execStateT) +import Data.Configurator.Types (Config) -import Network.IRC.Internal.Command.Types -import Network.IRC.Internal.Event.Types -import Network.IRC.Internal.Message.Types +import Network.IRC.Message.Types +import Network.IRC.MessageBus import Network.IRC.Util -- ** Message Parsing @@ -25,17 +23,17 @@ import Network.IRC.Util type MessageParserId = Text -- | A part of a mutlipart message. -data MessagePart = MessagePart { msgPartParserId :: !MessageParserId - , msgPartTarget :: !Text - , msgPartTime :: !UTCTime - , msgPartLine :: !Text +data MessagePart = MessagePart { msgPartParserId :: !MessageParserId + , msgPartTarget :: !Text + , msgPartTime :: !UTCTime + , msgPartLine :: !Text } deriving (Eq, Show) -- | The result of parsing a message line. data MessageParseResult = - Done !FullMessage ![MessagePart] -- ^ A fully parsed message and leftover message parts. - | Partial ![MessagePart] -- ^ A partial message with message parts received yet. - | Reject -- ^ Returned if a message line cannot be parsed by a particular parser. + Done !Message ![MessagePart] -- ^ A fully parsed message and leftover message parts. + | Partial ![MessagePart] -- ^ A partial message with message parts received yet. + | Reject -- ^ Returned if a message line cannot be parsed by a particular parser. deriving (Eq, Show) -- | A message parser used for parsing text lines from the server to 'Message's. @@ -47,7 +45,7 @@ data MessageParser = MessageParser -- ** Command Formatting -- | A command formatter which optinally formats commands to texts which are then send to the server. -type CommandFormatter = BotConfig -> Command -> Maybe Text +type CommandFormatter = BotConfig -> Message -> Maybe Text -- ** Bot @@ -58,11 +56,11 @@ type MsgHandlerName = Text data BotConfig = BotConfig { -- | The server to connect to. - server :: !Text + botServer :: !Text -- | The port to connect to. - , port :: !Int + , botPort :: !Int -- | The channel to join. - , channel :: !Text + , botChannel :: !Text -- | Nick of the bot. , botNick :: !Nick -- | The timeout in seconds after which bot automatically disconnects and tries to reconnect. @@ -72,7 +70,7 @@ data BotConfig = BotConfig -- by that message handler to the help text of that command. , msgHandlerInfo :: !(Map MsgHandlerName (Map Text Text)) -- | A list of 'MsgHandlerMaker's which are used to create message handlers for the bot. - , msgHandlerMakers :: ![MsgHandlerMaker] + , msgHandlerMakers :: !(Map MsgHandlerName MsgHandlerMaker) -- | A list of extra message parsers. Note that these parsers will always be called after the built-in ones. , msgParsers :: ![MessageParser] -- | A list of extra command formatters. Note that these formatters will always be called after the built-in ones. @@ -82,22 +80,23 @@ data BotConfig = BotConfig } instance Show BotConfig where - show BotConfig { .. } = "BotConfig[ server = " ++ show server ++ "\n" ++ - "port = " ++ show port ++ "\n" ++ - "channel = " ++ show channel ++ "\n" ++ - "nick = " ++ show botNick ++ "\n" ++ - "timeout = " ++ show botTimeout ++ "\n" ++ - "handlers = " ++ show (mapKeys msgHandlerInfo) ++ " ]" + show BotConfig { .. } = "BotConfig {" ++ "\n" ++ + "server = " ++ show botServer ++ "\n" ++ + "port = " ++ show botPort ++ "\n" ++ + "channel = " ++ show botChannel ++ "\n" ++ + "nick = " ++ show botNick ++ "\n" ++ + "timeout = " ++ show botTimeout ++ "\n" ++ + "handlers = " ++ show (mapKeys msgHandlerInfo) ++ " }" -- | Creates a new bot config with essential fields leaving rest fields empty. -newBotConfig :: Text -- ^ server - -> Int -- ^ port - -> Text -- ^ channel - -> Nick -- ^ botNick - -> Int -- ^ botTimeout +newBotConfig :: Text -- ^ server + -> Int -- ^ port + -> Text -- ^ channel + -> Nick -- ^ botNick + -> Int -- ^ botTimeout -> BotConfig newBotConfig server port channel botNick botTimeout = - BotConfig server port channel botNick botTimeout mempty [] [] [] CF.empty + BotConfig server port channel botNick botTimeout mempty mempty [] [] CF.empty -- | The bot. data Bot = Bot @@ -111,15 +110,15 @@ data Bot = Bot } -- | The current status of the bot. -data BotStatus = Connected -- ^ Connected to the server - | Disconnected -- ^ Disconnected from the server. - | Joined -- ^ Joined the channel. - | Kicked -- ^ Kicked from the channel. - | Errored -- ^ Some unhandled error happened. - | Idle -- ^ No communication with the server. The bot is idle. - -- If the bot stays idle for 'botTimeout' seconds, it disconnects. - | Interrupted -- ^ Interrupted using external signals like SIGINT. - | NickNotAvailable -- ^ Bot's nick already taken on the server. +data BotStatus = Connected -- ^ Connected to the server + | Disconnected -- ^ Disconnected from the server. + | Joined -- ^ Joined the channel. + | Kicked -- ^ Kicked from the channel. + | Errored -- ^ Some unhandled error happened. + | Idle -- ^ No communication with the server. The bot is idle. + -- If the bot stays idle for 'botTimeout' seconds, it disconnects. + | Interrupted -- ^ Interrupted using external signals like SIGINT. + | NickNotAvailable -- ^ Bot's nick already taken on the server. deriving (Show, Eq, Ord) -- | An IRC action to be run. @@ -162,23 +161,21 @@ data MsgHandler = MsgHandler { -- | The action invoked when a message is received. It returns a list of commands in response -- to the message which the bot sends to the server. - onMessage :: !(forall m . MonadMsgHandler m => FullMessage -> m [Command]) - -- | The action invoked when an event is triggered. It returns an event resonpse which the bot - -- handles according to its type. - , onEvent :: !(forall m . MonadMsgHandler m => Event -> m EventResponse) + onMessage :: !(forall m . MonadMsgHandler m => Message -> m [Message]) + -- | The action invoked to stop the message handler. - , onStop :: !(forall m . MonadMsgHandler m => m ()) + , onStop :: !(forall m . MonadMsgHandler m => m ()) + -- | The action invoked to get the map of the commands supported by the message handler and their help messages. - , onHelp :: !(forall m . MonadMsgHandler m => m (Map Text Text)) + , handlerHelp :: !(forall m . MonadMsgHandler m => m (Map Text Text)) } -- | Creates a new message handler which doesn't do anything. newMsgHandler :: MsgHandler newMsgHandler = MsgHandler - { onMessage = const $ return [] - , onStop = return () - , onEvent = const $ return RespNothing - , onHelp = return mempty + { onMessage = const $ return mempty + , onStop = return () + , handlerHelp = return mempty } -- | A message handler maker which creates a new message handler. @@ -187,7 +184,7 @@ data MsgHandlerMaker = MsgHandlerMaker -- | The name of the message handler. msgHandlerName :: !MsgHandlerName -- | The action which is invoked to create a new message handler. - , msgHandlerMaker :: !(BotConfig -> Chan Event -> MsgHandlerName -> IO (Maybe MsgHandler)) + , msgHandlerMaker :: !(BotConfig -> MessageChannel Message -> IO MsgHandler) } instance Eq MsgHandlerMaker where @@ -198,19 +195,11 @@ instance Ord MsgHandlerMaker where -- | Handles a message using a given message handler. handleMessage :: MsgHandler -- ^ The message handler. -> BotConfig -- ^ The bot config. - -> FullMessage -- ^ The message to handle. - -> IO [Command] -- ^ A list of commands to be sent to the server. + -> Message -- ^ The message to handle. + -> IO [Message] -- ^ A list of commands to be sent to the server. handleMessage MsgHandler { .. } botConfig = flip runReaderT botConfig . _runMsgHandler . onMessage --- | Handles an event using a given message handler. -handleEvent :: MsgHandler -- ^ The message handler. - -> BotConfig -- ^ The bot config. - -> Event -- ^ The event to handle. - -> IO EventResponse -- ^ The event response which will be dispatched by the bot. -handleEvent MsgHandler { .. } botConfig = - flip runReaderT botConfig . _runMsgHandler . onEvent - -- | Stops a message handler. stopMsgHandler :: MsgHandler -- ^ The message handler. -> BotConfig -- ^ The bot config. @@ -223,4 +212,4 @@ getHelp :: MsgHandler -- ^ The message handler. -> BotConfig -- ^ The bot config. -> IO (Map Text Text) -- ^ A map of the commands supported by this message handler to their help messages. getHelp MsgHandler { .. } botConfig = - flip runReaderT botConfig . _runMsgHandler $ onHelp + flip runReaderT botConfig . _runMsgHandler $ handlerHelp diff --git a/hask-irc-core/Network/IRC/Internal/Message/Types.hs b/hask-irc-core/Network/IRC/Message/Types.hs similarity index 64% rename from hask-irc-core/Network/IRC/Internal/Message/Types.hs rename to hask-irc-core/Network/IRC/Message/Types.hs index a7ebf60..f6c1fa0 100644 --- a/hask-irc-core/Network/IRC/Internal/Message/Types.hs +++ b/hask-irc-core/Network/IRC/Message/Types.hs @@ -4,15 +4,14 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_HADDOCK hide #-} -module Network.IRC.Internal.Message.Types where +module Network.IRC.Message.Types where import ClassyPrelude -import Data.Data (Data) -import Data.SafeCopy (base, deriveSafeCopy) -import Data.Typeable (cast) - --- ** IRC Message +import Data.Data (Data) +import Data.SafeCopy (base, deriveSafeCopy) +import Data.Typeable (cast) -- | An IRC nick. newtype Nick = Nick { nickToText :: Text } @@ -34,31 +33,36 @@ data User } deriving (Show, Eq, Ord) -- | An IRC message sent from the server to the bot. -data FullMessage = FullMessage +data Message = Message { msgTime :: !UTCTime -- ^ The time when the message was received. , msgLine :: !Text -- ^ The raw message line. - , message :: Message -- ^ The details of the parsed message. + , message :: MessageW -- ^ The details of the parsed message. } deriving (Show, Eq) -- | The typeclass for different types of IRC messages. class (Typeable msg, Show msg, Eq msg, Ord msg) => MessageC msg where - toMessage :: msg -> Message - toMessage = Message + toMessage :: msg -> MessageW + toMessage = MessageW - fromMessage :: Message -> Maybe msg - fromMessage (Message msg) = cast msg + fromMessage :: MessageW -> Maybe msg + fromMessage (MessageW msg) = cast msg -- | A wrapper over all types of IRC messages. -data Message = forall m . MessageC m => Message m deriving (Typeable) +data MessageW = forall m . MessageC m => MessageW m deriving (Typeable) -instance Show Message where - show (Message m) = show m +instance Show MessageW where + show (MessageW m) = show m -instance Eq Message where - Message m1 == Message m2 = case cast m1 of +instance Eq MessageW where + MessageW m1 == MessageW m2 = case cast m1 of Just m1' -> m1' == m2 _ -> False +newMessage :: (MessageC msg, MonadIO m) => msg -> m Message +newMessage msg = do + t <- liftIO getCurrentTime + return $ Message t "" (toMessage msg) + -- | The internal (non-IRC) message received when the bot is idle. data IdleMsg = IdleMsg deriving (Typeable, Show, Eq, Ord) instance MessageC IdleMsg @@ -121,3 +125,40 @@ instance MessageC ModeMsg data OtherMsg = OtherMsg { msgSource :: !Text, msgCommand :: !Text, msgTarget :: !Text , msg :: !Text } deriving (Typeable, Show, Eq, Ord) instance MessageC OtherMsg + + +-- | A /PING/ command. A 'PongMsg' is expected as a response to this. +data PingCmd = PingCmd !Text deriving (Typeable, Show, Eq, Ord) +instance MessageC PingCmd + +-- | A /PONG/ command. Sent in response to a 'PingMsg'. +data PongCmd = PongCmd !Text deriving (Typeable, Show, Eq, Ord) +instance MessageC PongCmd + +-- | A /PRIVMSG/ message sent to the channel. +data ChannelMsgReply = ChannelMsgReply !Text deriving (Typeable, Show, Eq, Ord) +instance MessageC ChannelMsgReply + +-- | A /PRIVMSG/ message sent to a user. +data PrivMsgReply = PrivMsgReply !User !Text deriving (Typeable, Show, Eq, Ord) +instance MessageC PrivMsgReply + +-- | A /NICK/ command sent to set the bot's nick. +data NickCmd = NickCmd deriving (Typeable, Show, Eq, Ord) +instance MessageC NickCmd + +-- | A /USER/ command sent to identify the bot. +data UserCmd = UserCmd deriving (Typeable, Show, Eq, Ord) +instance MessageC UserCmd + +-- | A /JOIN/ command sent to join the channel. +data JoinCmd = JoinCmd deriving (Typeable, Show, Eq, Ord) +instance MessageC JoinCmd + +-- | A /QUIT/ command sent to quit the server. +data QuitCmd = QuitCmd deriving (Typeable, Show, Eq, Ord) +instance MessageC QuitCmd + +-- | A /NAMES/ command sent to ask for the nicks of the users in the channel. +data NamesCmd = NamesCmd deriving (Typeable, Show, Eq, Ord) +instance MessageC NamesCmd diff --git a/hask-irc-core/Network/IRC/MessageBus.hs b/hask-irc-core/Network/IRC/MessageBus.hs new file mode 100644 index 0000000..199e6c6 --- /dev/null +++ b/hask-irc-core/Network/IRC/MessageBus.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} + +module Network.IRC.MessageBus + ( MessageBus + , newMessageBus + , MessageChannel + , newMessageChannel + , sendMessage + , receiveMessage + , closeMessageChannel + , awaitMessageChannel ) where + +import ClassyPrelude + +newtype Latch = Latch (MVar ()) + +newLatch :: IO Latch +newLatch = liftM Latch newEmptyMVar + +doLatch :: Latch -> IO () +doLatch (Latch mv) = putMVar mv () + +awaitLatch :: Latch -> IO () +awaitLatch (Latch mv) = void $ takeMVar mv + +newtype MessageBus a = MessageBus (TChan a) + +newMessageBus :: IO (MessageBus a) +newMessageBus = MessageBus <$> newBroadcastTChanIO + +data MessageChannel a = MessageChannel Latch (TChan a) (TChan a) + +newMessageChannel ::MessageBus a -> IO (MessageChannel a) +newMessageChannel (MessageBus wChan) = do + latch <- newLatch + rChan <- atomically $ dupTChan wChan + return $ MessageChannel latch rChan wChan + +sendMessageSTM :: MessageChannel a -> a -> STM () +sendMessageSTM (MessageChannel _ _ wChan) = writeTChan wChan + +receiveMessageSTM :: MessageChannel a -> STM a +receiveMessageSTM (MessageChannel _ rChan _) = readTChan rChan + +sendMessage :: MessageChannel a -> a -> IO () +sendMessage chan = atomically . sendMessageSTM chan + +receiveMessage :: MessageChannel a -> IO a +receiveMessage = atomically . receiveMessageSTM + +closeMessageChannel :: MessageChannel a -> IO () +closeMessageChannel (MessageChannel latch _ _) = doLatch latch + +awaitMessageChannel :: MessageChannel a -> IO () +awaitMessageChannel (MessageChannel latch _ _) = awaitLatch latch diff --git a/hask-irc-core/Network/IRC/Protocol.hs b/hask-irc-core/Network/IRC/Protocol.hs index 813c1b0..19363b9 100644 --- a/hask-irc-core/Network/IRC/Protocol.hs +++ b/hask-irc-core/Network/IRC/Protocol.hs @@ -10,7 +10,7 @@ import Data.Text (strip) import Network.IRC.Types -parseLine :: BotConfig -> UTCTime -> Text -> [MessagePart] -> (Maybe FullMessage, [MessagePart]) +parseLine :: BotConfig -> UTCTime -> Text -> [MessagePart] -> (Maybe Message, [MessagePart]) parseLine botConfig@BotConfig { .. } time line msgParts = fromMaybe (Nothing, msgParts) . msum . flip map parsers $ \MessageParser { .. } -> let (parserMsgParts, otherParserMsgParts) = partition ((msgParserId ==) . msgPartParserId) msgParts @@ -25,7 +25,7 @@ pingParser :: MessageParser pingParser = MessageParser "ping" go where go _ time line _ - | "PING :" `isPrefixOf` line = Done (FullMessage time line . toMessage . PingMsg . drop 6 $ line) [] + | "PING :" `isPrefixOf` line = Done (Message time line . toMessage . PingMsg . drop 6 $ line) [] | otherwise = Reject parseMsgLine :: Text -> ([Text], Text, Text, Text, Text) @@ -47,17 +47,17 @@ lineParser = MessageParser "line" go "QUIT" -> done $ toMessage $ QuitMsg user quitMessage "PART" -> done $ toMessage $ PartMsg user message "KICK" -> done $ toMessage $ KickMsg user (Nick kicked) kickReason - "MODE" -> done $ toMessage $ if Nick source == botNick + "MODE" -> done $ toMessage $ if Nick target == botNick then ModeMsg Self target message [] else ModeMsg user target mode modeArgs "NICK" -> done $ toMessage $ NickMsg user $ Nick (drop 1 target) "433" -> done $ toMessage NickInUseMsg - "PRIVMSG" | target /= channel -> done $ toMessage $ PrivMsg user message - | isActionMsg -> done $ toMessage $ ActionMsg user (initDef . drop 8 $ message) - | otherwise -> done $ toMessage $ ChannelMsg user message + "PRIVMSG" | target /= botChannel -> done $ toMessage $ PrivMsg user message + | isActionMsg -> done $ toMessage $ ActionMsg user (initDef . drop 8 $ message) + | otherwise -> done $ toMessage $ ChannelMsg user message _ -> Reject where - done = flip Done [] . FullMessage time line + done = flip Done [] . Message time line (splits, command, source, target, message) = parseMsgLine line quitMessage = strip . drop 1 . unwords . drop 2 $ splits @@ -71,7 +71,7 @@ lineParser = MessageParser "line" go defaultParser :: MessageParser defaultParser = MessageParser "default" go where - go _ time line _ = flip Done [] . FullMessage time line $ + go _ time line _ = flip Done [] . Message time line $ toMessage $ OtherMsg source command target message where (_, command, source, target, message) = parseMsgLine line @@ -85,7 +85,7 @@ namesParser = MessageParser "names" go (myMsgParts, otherMsgParts) = partition ((target ==) . msgPartTarget) msgParts (nicks, allLines) = concat *** intercalate "\r\n" . (++ [line]) $ unzip $ map (\MessagePart { .. } -> (namesNicks msgPartLine, msgPartLine)) myMsgParts - in Done (FullMessage time allLines . toMessage $ NamesMsg nicks) otherMsgParts + in Done (Message time allLines . toMessage $ NamesMsg nicks) otherMsgParts _ -> Reject where (_ : command : target : _) = words line @@ -94,23 +94,23 @@ namesParser = MessageParser "names" go map (Nick . stripNickPrefix) . words . drop 1 . unwords . drop 5 . words $ line' formatCommand :: CommandFormatter -formatCommand botConfig@BotConfig { .. } command = - msum . map (\formatter -> formatter botConfig command) $ defaultCommandFormatter : cmdFormatters +formatCommand botConfig@BotConfig { .. } message = + msum . map (\formatter -> formatter botConfig message) $ defaultCommandFormatter : cmdFormatters defaultCommandFormatter :: CommandFormatter -defaultCommandFormatter BotConfig { .. } command - | Just (PongCmd msg) <- fromCommand command = Just $ "PONG :" ++ msg - | Just (PingCmd msg) <- fromCommand command = Just $ "PING :" ++ msg - | Just NickCmd <- fromCommand command = Just $ "NICK " ++ botNick' - | Just UserCmd <- fromCommand command = +defaultCommandFormatter BotConfig { .. } Message { .. } + | Just (PongCmd msg) <- fromMessage message = Just $ "PONG :" ++ msg + | Just (PingCmd msg) <- fromMessage message = Just $ "PING :" ++ msg + | Just NickCmd <- fromMessage message = Just $ "NICK " ++ botNick' + | Just UserCmd <- fromMessage message = Just $ "USER " ++ botNick' ++ " 0 * :" ++ botNick' - | Just JoinCmd <- fromCommand command = Just $ "JOIN " ++ channel - | Just QuitCmd <- fromCommand command = Just "QUIT" - | Just (ChannelMsgReply msg) <- fromCommand command = - Just $ "PRIVMSG " ++ channel ++ " :" ++ msg - | Just (PrivMsgReply (User { .. }) msg) <- fromCommand command = + | Just JoinCmd <- fromMessage message = Just $ "JOIN " ++ botChannel + | Just QuitCmd <- fromMessage message = Just "QUIT" + | Just (ChannelMsgReply msg) <- fromMessage message = + Just $ "PRIVMSG " ++ botChannel ++ " :" ++ msg + | Just (PrivMsgReply (User { .. }) msg) <- fromMessage message = Just $ "PRIVMSG " ++ nickToText userNick ++ " :" ++ msg - | Just NamesCmd <- fromCommand command = Just $ "NAMES " ++ channel + | Just NamesCmd <- fromMessage message = Just $ "NAMES " ++ botChannel | otherwise = Nothing where botNick' = nickToText botNick diff --git a/hask-irc-core/Network/IRC/Types.hs b/hask-irc-core/Network/IRC/Types.hs index 4736079..00273aa 100644 --- a/hask-irc-core/Network/IRC/Types.hs +++ b/hask-irc-core/Network/IRC/Types.hs @@ -14,8 +14,8 @@ module Network.IRC.Types Nick (..) , User (..) , MessageC (..) - , Message - , FullMessage (..) + , Message (..) + , newMessage , IdleMsg (..) , NickInUseMsg (..) , PingMsg (..) @@ -32,8 +32,6 @@ module Network.IRC.Types , ModeMsg (..) , OtherMsg (..) -- * IRC Commands - , CommandC (..) - , Command , PingCmd (..) , PongCmd (..) , ChannelMsgReply (..) @@ -50,11 +48,6 @@ module Network.IRC.Types , MessageParser (..) -- * Command Formatting , CommandFormatter - -- * Events - , EventC (..) - , Event - , EventResponse (..) - , QuitEvent(..) -- * Bot , BotConfig (..) , newBotConfig @@ -68,8 +61,5 @@ module Network.IRC.Types , MsgHandlerMaker (..) ) where -import Network.IRC.Internal.Command.Types -import Network.IRC.Internal.Event.Types -import Network.IRC.Internal.Message.Types +import Network.IRC.Message.Types import Network.IRC.Internal.Types - diff --git a/hask-irc-core/Network/IRC/Util.hs b/hask-irc-core/Network/IRC/Util.hs index 8ac0ffc..7efc0f7 100644 --- a/hask-irc-core/Network/IRC/Util.hs +++ b/hask-irc-core/Network/IRC/Util.hs @@ -6,28 +6,17 @@ module Network.IRC.Util where import qualified Data.Text.Format as TF import ClassyPrelude -import Control.Arrow (Arrow) -import Control.Concurrent.Lifted (Chan) -import Control.Monad.Base (MonadBase) -import Data.Convertible (convert) -import Data.Text (strip) -import Data.Time (diffUTCTime) +import Control.Arrow (Arrow) +import Control.Monad.Base (MonadBase) +import Data.Convertible (convert) +import Data.Text (strip) +import Data.Time (diffUTCTime) oneSec :: Int oneSec = 1000000 -type Latch = MVar () - -latchIt :: Latch -> IO () -latchIt latch = putMVar latch () - -awaitLatch :: Latch -> IO () -awaitLatch latch = void $ takeMVar latch - -type Channel a = (Chan a, Latch) - mapKeys :: IsMap map => map -> [ContainerKey map] -mapKeys = map fst . mapToList +mapKeys = map fst . mapToList mapValues :: IsMap map => map -> [MapValue map] mapValues = map snd . mapToList @@ -64,21 +53,21 @@ relativeTime t1 t2 = period = t1 `diffUTCTime` t2 - ranges = [(year*2, "{} years", year) - ,(year, "a year", 0) - ,(month*2, "{} months", month) - ,(month, "a month", 0) - ,(week*2, "{} weeks", week) - ,(week, "a week", 0) - ,(day*2, "{} days", day) - ,(day, "a day", 0) - ,(hour*4, "{} hours", hour) - ,(hour*3, "a few hours", 0) - ,(hour*2, "{} hours", hour) - ,(hour, "an hour", 0) - ,(minute*31, "{} minutes", minute) - ,(minute*30, "half an hour", 0) - ,(minute*2, "{} minutes", minute) - ,(minute, "a minute", 0) - ,(0, "{} seconds", 1) + ranges = [ (year*2, "{} years", year) + , (year, "a year", 0) + , (month*2, "{} months", month) + , (month, "a month", 0) + , (week*2, "{} weeks", week) + , (week, "a week", 0) + , (day*2, "{} days", day) + , (day, "a day", 0) + , (hour*4, "{} hours", hour) + , (hour*3, "a few hours", 0) + , (hour*2, "{} hours", hour) + , (hour, "an hour", 0) + , (minute*31, "{} minutes", minute) + , (minute*30, "half an hour", 0) + , (minute*2, "{} minutes", minute) + , (minute, "a minute", 0) + , (0, "{} seconds", 1) ] diff --git a/hask-irc-core/hask-irc-core.cabal b/hask-irc-core/hask-irc-core.cabal index 548947b..712e452 100644 --- a/hask-irc-core/hask-irc-core.cabal +++ b/hask-irc-core/hask-irc-core.cabal @@ -51,7 +51,7 @@ cabal-version: >=1.10 library default-extensions: NoImplicitPrelude, OverloadedStrings, RecordWildCards, ScopedTypeVariables, BangPatterns, TupleSections, NamedFieldPuns, GeneralizedNewtypeDeriving, - DeriveDataTypeable + DeriveDataTypeable, Trustworthy build-depends: base >=4.5 && <4.8, classy-prelude >=0.9 && <1.0, @@ -63,6 +63,7 @@ library mtl >=2.1 && <2.3, network >=2.5 && <2.6, safecopy >=0.8 && <0.9, + stm >=2.4 && <2.5, text >=1.1 && <1.2, text-format >=0.3 && <0.4, time >=1.4 && <1.5, @@ -70,14 +71,13 @@ library unix >=2.7 && <2.8 exposed-modules: Network.IRC, + Network.IRC.MessageBus, Network.IRC.Types, Network.IRC.Client, Network.IRC.Util - other-modules: Network.IRC.Internal.Command.Types, - Network.IRC.Internal.Event.Types, - Network.IRC.Internal.Message.Types, - Network.IRC.Internal.Types, + other-modules: Network.IRC.Internal.Types, + Network.IRC.Message.Types, Network.IRC.Protocol, Network.IRC.Bot, Network.IRC.Handlers.Core diff --git a/hask-irc-handlers/Network/IRC/Handlers.hs b/hask-irc-handlers/Network/IRC/Handlers.hs index b58c3d1..e97b98a 100644 --- a/hask-irc-handlers/Network/IRC/Handlers.hs +++ b/hask-irc-handlers/Network/IRC/Handlers.hs @@ -13,6 +13,7 @@ allMsgHandlerMakers :: [MsgHandlerMaker] allMsgHandlerMakers = [ authMsgHandlerMaker , greetMsgHandlerMaker + , welcomeMsgHandlerMaker , messageLoggerMsgHandlerMaker , nickTrackerMsgHandlerMaker , songSearchMsgHandlerMaker diff --git a/hask-irc-handlers/Network/IRC/Handlers/Auth.hs b/hask-irc-handlers/Network/IRC/Handlers/Auth.hs index 232c012..13a3c8b 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/Auth.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/Auth.hs @@ -13,8 +13,8 @@ import Data.Acid (AcidState, Query, Update, makeAcidic, query, update openLocalState, createArchive) import Data.Acid.Local (createCheckpointAndClose) +import Network.IRC import Network.IRC.Handlers.Auth.Types -import Network.IRC.Types import Network.IRC.Util -- database @@ -42,12 +42,20 @@ issueToken acid user = do -- handler -authMessage :: MonadMsgHandler m => IORef (AcidState Auth) -> FullMessage -> m [Command] -authMessage state FullMessage { .. } +authMessage :: MonadMsgHandler m => IORef (AcidState Auth) -> Message -> m [Message] +authMessage state Message { .. } | Just (PrivMsg user msg) <- fromMessage message - , "token" `isPrefixOf` msg = - map (singleton . toCommand . PrivMsgReply user) . io $ readIORef state >>= flip issueToken (userNick user) -authMessage _ _ = return [] + , "token" `isPrefixOf` msg = do + token <- io $ readIORef state >>= flip issueToken (userNick user) + map singleton . newMessage $ PrivMsgReply user token + | Just (AuthRequest user token reply) <- fromMessage message = io $ do + acid <- readIORef state + mt <- query acid (GetToken user) + case mt of + Just t -> putMVar reply (t == token) + Nothing -> putMVar reply False + return [] + | otherwise = return [] stopAuth :: MonadMsgHandler m => IORef (AcidState Auth) -> m () stopAuth state = io $ do @@ -55,26 +63,13 @@ stopAuth state = io $ do createArchive acid createCheckpointAndClose acid -authEvent :: MonadMsgHandler m => IORef (AcidState Auth) -> Event -> m EventResponse -authEvent state event = case fromEvent event of - Just (AuthEvent user token reply, _) -> io $ do - acid <- readIORef state - mt <- query acid (GetToken user) - case mt of - Just t -> putMVar reply (t == token) - Nothing -> putMVar reply False - return RespNothing - _ -> return RespNothing - authMsgHandlerMaker :: MsgHandlerMaker authMsgHandlerMaker = MsgHandlerMaker "auth" go where helpMsg botNick = "Send a PM to get a new auth token. /msg " ++ nickToText botNick ++ " token" - go BotConfig { .. } _ "auth" = do + go BotConfig { .. } _ = do state <- io $ openLocalState emptyAuth >>= newIORef - return . Just $ newMsgHandler { onMessage = authMessage state - , onEvent = authEvent state - , onStop = stopAuth state - , onHelp = return $ singletonMap "token" (helpMsg botNick) } - go _ _ _ = return Nothing + return $ newMsgHandler { onMessage = authMessage state + , onStop = stopAuth state + , handlerHelp = return $ singletonMap "token" (helpMsg botNick) } diff --git a/hask-irc-handlers/Network/IRC/Handlers/Auth/Types.hs b/hask-irc-handlers/Network/IRC/Handlers/Auth/Types.hs index 6e7f63c..ccd87c0 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/Auth/Types.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/Auth/Types.hs @@ -17,10 +17,13 @@ emptyAuth = Auth mempty $(deriveSafeCopy 0 'base ''Auth) -data AuthEvent = AuthEvent Nick Token (MVar Bool) deriving (Eq, Typeable) +data AuthRequest = AuthRequest Nick Token (MVar Bool) deriving (Eq, Typeable) -instance EventC AuthEvent +instance MessageC AuthRequest -instance Show AuthEvent where - show (AuthEvent nick token _) = - "AuthEvent[" ++ unpack (nickToText nick) ++ ", " ++ unpack token ++ "]" +instance Show AuthRequest where + show (AuthRequest nick token _) = + "AuthRequest[" ++ unpack (nickToText nick) ++ ", " ++ unpack token ++ "]" + +instance Ord AuthRequest where + (AuthRequest nick1 _ _) `compare` (AuthRequest nick2 _ _) = nick1 `compare` nick2 diff --git a/hask-irc-handlers/Network/IRC/Handlers/Greet.hs b/hask-irc-handlers/Network/IRC/Handlers/Greet.hs index b8a165d..2e9e62f 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/Greet.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/Greet.hs @@ -1,34 +1,37 @@ -module Network.IRC.Handlers.Greet (greetMsgHandlerMaker) where +module Network.IRC.Handlers.Greet (greetMsgHandlerMaker, welcomeMsgHandlerMaker) where import ClassyPrelude import Control.Monad.Reader (ask) -import Network.IRC.Types +import Network.IRC import Network.IRC.Util greetMsgHandlerMaker :: MsgHandlerMaker -greetMsgHandlerMaker = MsgHandlerMaker "greeter" go - where - go _ _ "greeter" = return . Just $ newMsgHandler { onMessage = greeter } - go _ _ "welcomer" = return . Just $ newMsgHandler { onMessage = welcomer } - go _ _ _ = return Nothing +greetMsgHandlerMaker = + MsgHandlerMaker "greeter" $ \_ _ -> return $ newMsgHandler { onMessage = greeter } -greeter :: MonadMsgHandler m => FullMessage -> m [Command] -greeter FullMessage { .. } = case fromMessage message of +welcomeMsgHandlerMaker :: MsgHandlerMaker +welcomeMsgHandlerMaker = + MsgHandlerMaker "welcomer" $ \_ _ -> return $ newMsgHandler { onMessage = welcomer } + +greeter :: MonadMsgHandler m => Message -> m [Message] +greeter Message { .. } = case fromMessage message of Just (ChannelMsg user msg) -> - return . maybeToList . map (toCommand . ChannelMsgReply . (++ nickToText (userNick user)) . (++ " ")) - . find (== clean msg) $ greetings + let reply = maybeToList . map (ChannelMsgReply . (++ nickToText (userNick user)) . (++ " ")) + . find (== clean msg) $ greetings + in mapM newMessage reply _ -> return [] where greetings = [ "hi", "hello", "hey", "sup", "bye" , "good morning", "good evening", "good night" ] -welcomer :: MonadMsgHandler m => FullMessage -> m [Command] -welcomer FullMessage { .. } = case fromMessage message of +welcomer :: MonadMsgHandler m => Message -> m [Message] +welcomer Message { .. } = case fromMessage message of Just (JoinMsg user) -> do BotConfig { .. } <- ask - return [toCommand . ChannelMsgReply $ "welcome back " ++ nickToText (userNick user) - | userNick user /= botNick] + if userNick user /= botNick + then map singleton . newMessage . ChannelMsgReply $ "welcome back " ++ nickToText (userNick user) + else return [] _ -> return [] diff --git a/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs b/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs index 4b7a493..9bef65d 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs @@ -14,7 +14,7 @@ import System.Directory (createDirectoryIfMissing, getModificationTime, import System.FilePath (FilePath, (), (<.>)) import System.IO (openFile, IOMode(..), hSetBuffering, BufferMode(..)) -import Network.IRC.Types +import Network.IRC import Network.IRC.Util type LoggerState = Maybe (Handle, Day) @@ -22,18 +22,17 @@ type LoggerState = Maybe (Handle, Day) messageLoggerMsgHandlerMaker :: MsgHandlerMaker messageLoggerMsgHandlerMaker = MsgHandlerMaker "messagelogger" go where - go botConfig _ "messagelogger" = do + go botConfig _ = do state <- io $ newIORef Nothing initMessageLogger botConfig state - return . Just $ newMsgHandler { onMessage = flip messageLogger state - , onStop = exitMessageLogger state } - go _ _ _ = return Nothing + return $ newMsgHandler { onMessage = flip messageLogger state + , onStop = exitMessageLogger state } getLogFilePath :: BotConfig -> IO FilePath getLogFilePath BotConfig { .. } = do logFileDir <- CF.require config "messagelogger.logdir" createDirectoryIfMissing True logFileDir - return $ logFileDir unpack (channel ++ "-" ++ nickToText botNick) <.> "log" + return $ logFileDir unpack (botChannel ++ "-" ++ nickToText botNick) <.> "log" openLogFile :: FilePath -> IO Handle openLogFile logFilePath = do @@ -51,7 +50,7 @@ initMessageLogger botConfig state = do exitMessageLogger :: MonadMsgHandler m => IORef LoggerState -> m () exitMessageLogger state = io $ readIORef state >>= flip whenJust (hClose . fst) -withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m [Command] +withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m [Message] withLogFile action state = do botConfig <- ask io $ do @@ -73,8 +72,8 @@ withLogFile action state = do return [] -messageLogger :: MonadMsgHandler m => FullMessage -> IORef LoggerState -> m [Command] -messageLogger FullMessage { .. } +messageLogger :: MonadMsgHandler m => Message -> IORef LoggerState -> m [Message] +messageLogger Message { .. } | Just (ChannelMsg user msg) <- fromMessage message = log "<{}> {}" [nick user, msg] | Just (ActionMsg user msg) <- fromMessage message = @@ -91,7 +90,8 @@ messageLogger FullMessage { .. } log "** {} CHANGED NICK TO {}" [nick user, nickToText newNick] | Just (NamesMsg nicks) <- fromMessage message = log "** USERS {}" [unwords . map nickToText $ nicks] - | otherwise = const $ return [] + | otherwise = + const $ return [] where nick = nickToText . userNick diff --git a/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs b/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs index 7a4149e..2ef9667 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs @@ -18,8 +18,8 @@ import Data.Convertible (convert) import Data.IxSet (getOne, (@=)) import Data.Time (addUTCTime, NominalDiffTime) +import Network.IRC import Network.IRC.Handlers.NickTracker.Internal.Types -import Network.IRC.Types import Network.IRC.Util -- database @@ -54,8 +54,8 @@ data NickTrackingState = NickTrackingState { acid :: AcidState NickTr , onlineNicks :: HashSet Nick , lastRefreshOn :: UTCTime } -nickTrackerMsg :: MonadMsgHandler m => IORef NickTrackingState -> FullMessage -> m [Command] -nickTrackerMsg state FullMessage { .. } +nickTrackerMsg :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m [Message] +nickTrackerMsg state Message { .. } | Just (ChannelMsg (User { .. }) msg) <- fromMessage message = updateNickTrack state userNick msg msgTime >> handleCommands userNick msg | Just (ActionMsg (User { .. }) msg) <- fromMessage message = @@ -68,15 +68,18 @@ nickTrackerMsg state FullMessage { .. } updateNickTrack state userNick msg msgTime >> remove userNick >> return [] | Just (NickMsg (User { .. }) newNick) <- fromMessage message = handleNickChange state userNick newNick msgTime >> swap (userNick, newNick) >> return [] - | Just (NamesMsg nicks) <- fromMessage message = do + | Just (NamesMsg nicks) <- fromMessage message = do forM_ nicks $ \n -> updateNickTrack state n "" msgTime refresh nicks >> updateRefreshTime >> return [] - | Just IdleMsg <- fromMessage message = do + | Just IdleMsg <- fromMessage message = do NickTrackingState { .. } <- readIORef state if addUTCTime refreshInterval lastRefreshOn < msgTime - then updateRefreshTime >> return [toCommand NamesCmd] + then updateRefreshTime >> map singleton (newMessage NamesCmd) else return [] - | otherwise = return [] + | Just (NickTrackRequest nick reply) <- fromMessage message = io $ do + NickTrackingState { .. } <- readIORef state + getByNick acid nick >>= putMVar reply >> return [] + | otherwise = return [] where updateRefreshTime = atomicModIORef state $ \ s -> s { lastRefreshOn = msgTime } @@ -96,8 +99,8 @@ nickTrackerMsg state FullMessage { .. } updateNickTrack :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> UTCTime -> m () updateNickTrack state nck message msgTime = io $ do - NickTrackingState { .. } <- readIORef state - mnt <- getByNick acid nck + NickTrackingState { .. } <- readIORef state + mnt <- getByNick acid nck (message', lastMessageOn', cn) <- case (message, mnt) of ("", Just (NickTrack { .. })) -> return (lastMessage, lastMessageOn, canonicalNick) (_, Just (NickTrack { .. })) -> return (message, msgTime, canonicalNick) @@ -108,9 +111,9 @@ updateNickTrack state nck message msgTime = io $ do handleNickChange :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Nick -> UTCTime -> m () handleNickChange state prevNick newNick msgTime = io $ do NickTrackingState { .. } <- readIORef state - mpnt <- getByNick acid prevNick - mnt <- getByNick acid newNick - mInfo <- case (mpnt, mnt) of + mpnt <- getByNick acid prevNick + mnt <- getByNick acid newNick + mInfo <- case (mpnt, mnt) of (Nothing, _) -> newCanonicalNick >>= \cn -> return $ Just ("", cn, msgTime) (Just pnt, Nothing) -> return $ Just (lastMessage pnt, canonicalNick pnt, lastMessageOn pnt) @@ -128,26 +131,27 @@ newCanonicalNick = map (CanonicalNick . pack . U.toString) U.nextRandom withNickTracks :: MonadMsgHandler m => (Text -> [NickTrack] -> HashSet Nick -> IO Text) -> IORef NickTrackingState -> Nick -> Text - -> m [Command] + -> m [Message] withNickTracks f state _ msg = io $ do NickTrackingState { .. } <- readIORef state let nick = clean . unwords . drop 1 . words $ msg if nick == "" then return [] else do - mcn <- liftM (map canonicalNick) . getByNick acid . Nick $ nick - map (singleton . toCommand . ChannelMsgReply) $ case mcn of + mcn <- liftM (map canonicalNick) . getByNick acid . Nick $ nick + reply <- case mcn of Nothing -> return $ "Unknown nick: " ++ nick Just cn -> io $ query acid (GetByCanonicalNickQ cn) >>= \nts -> f nick nts onlineNicks + map singleton . newMessage . ChannelMsgReply $ reply -handleNickCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Command] +handleNickCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Message] handleNickCommand = withNickTracks $ \nck nickTracks _ -> do let nicks = map ((\(Nick n) -> n) . nick) nickTracks return . (nck ++) $ if length nicks == 1 then " has only one nick" else "'s other nicks are: " ++ intercalate ", " (filter (/= nck) nicks) -handleSeenCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Command] +handleSeenCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Message] handleSeenCommand = withNickTracks $ \nck nickTracks onlineNicks -> do let NickTrack { lastSeenOn = lastSeenOn' , nick = Nick lastSeenAs } = maximumByEx (comparing lastSeenOn) nickTracks @@ -165,21 +169,14 @@ handleSeenCommand = withNickTracks $ \nck nickTracks onlineNicks -> do (if nck /= lastMessageAs then " as " ++ lastMessageAs else "") ++ " said: " ++ lastMessage') -handleForgetNicksCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Command] +handleForgetNicksCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Message] handleForgetNicksCommand state nick _ = do NickTrackingState { .. } <- readIORef state io $ do Just nt <- getByNick acid nick cn <- newCanonicalNick saveNickTrack acid $ nt { canonicalNick = cn } - return [toCommand . ChannelMsgReply $ "Forgot all alternate nicks of " ++ nickToText nick] - -nickTrackerEvent :: MonadMsgHandler m => IORef NickTrackingState -> Event -> m EventResponse -nickTrackerEvent state event = case fromEvent event of - Just (NickTrackRequest nick reply, _) -> io $ do - NickTrackingState { .. } <- readIORef state - getByNick acid nick >>= putMVar reply >> return RespNothing - _ -> return RespNothing + map singleton . newMessage . ChannelMsgReply $ "Forgot all alternate nicks of " ++ nickToText nick stopNickTracker :: MonadMsgHandler m => IORef NickTrackingState -> m () stopNickTracker state = io $ do @@ -195,14 +192,12 @@ nickTrackerMsgHandlerMaker = MsgHandlerMaker "nicktracker" go ("!seen", "Lets you know when a user was last seen online and last spoke in the channel. !seen "), ("!forgetnicks", "Forgets all your alternate nicks. !forgetnicks") ] - go BotConfig { .. } _ "nicktracker" = do + go BotConfig { .. } _ = do state <- io $ do now <- getCurrentTime refreshInterval <- map convert (CF.lookupDefault 60 config "nicktracker.refresh_interval" :: IO Int) acid <- openLocalState emptyNickTracking newIORef (NickTrackingState acid refreshInterval mempty now) - return . Just $ newMsgHandler { onMessage = nickTrackerMsg state - , onEvent = nickTrackerEvent state - , onStop = stopNickTracker state - , onHelp = return helpMsgs } - go _ _ _ = return Nothing + return $ newMsgHandler { onMessage = nickTrackerMsg state + , onStop = stopNickTracker state + , handlerHelp = return helpMsgs } diff --git a/hask-irc-handlers/Network/IRC/Handlers/NickTracker/Internal/Types.hs b/hask-irc-handlers/Network/IRC/Handlers/NickTracker/Internal/Types.hs index 51f8bc2..b5d650f 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/NickTracker/Internal/Types.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/NickTracker/Internal/Types.hs @@ -3,24 +3,23 @@ module Network.IRC.Handlers.NickTracker.Internal.Types where import ClassyPrelude -import Control.Concurrent.Lifted (Chan, writeChan) -import Data.Data (Data) -import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun) -import Data.SafeCopy (base, deriveSafeCopy) +import Data.Data (Data) +import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun) +import Data.SafeCopy (base, deriveSafeCopy) -import Network.IRC.Types +import Network.IRC newtype CanonicalNick = CanonicalNick { canonicalNickToText :: Text } deriving (Eq, Ord, Show, Data, Typeable) newtype LastSeenOn = LastSeenOn UTCTime deriving (Eq, Ord, Show, Data, Typeable) -data NickTrack = NickTrack { - nick :: !Nick, - canonicalNick :: !CanonicalNick, - lastSeenOn :: !UTCTime, - lastMessageOn :: !UTCTime, - lastMessage :: !Text -} deriving (Eq, Ord, Show, Data, Typeable) +data NickTrack = NickTrack + { nick :: !Nick + , canonicalNick :: !CanonicalNick + , lastSeenOn :: !UTCTime + , lastMessageOn :: !UTCTime + , lastMessage :: !Text + } deriving (Eq, Ord, Show, Data, Typeable) instance Indexable NickTrack where empty = ixSet [ ixFun $ (: []) . nick @@ -40,14 +39,17 @@ emptyNickTracking = NickTracking empty data NickTrackRequest = NickTrackRequest Nick (MVar (Maybe NickTrack)) deriving (Eq, Typeable) -instance EventC NickTrackRequest +instance MessageC NickTrackRequest instance Show NickTrackRequest where show (NickTrackRequest nick _) = "NickTrackRequest[" ++ unpack (nickToText nick) ++ "]" -getCanonicalNick :: Chan Event -> Nick -> IO (Maybe CanonicalNick) -getCanonicalNick eventChan nick = do +instance Ord NickTrackRequest where + (NickTrackRequest nick1 _) `compare` (NickTrackRequest nick2 _) = nick1 `compare` nick2 + +getCanonicalNick :: MessageChannel Message -> Nick -> IO (Maybe CanonicalNick) +getCanonicalNick messageChannel nick = do reply <- newEmptyMVar - request <- toEvent $ NickTrackRequest nick reply - writeChan eventChan request + request <- newMessage $ NickTrackRequest nick reply + sendMessage messageChannel request map (map canonicalNick) $ takeMVar reply diff --git a/hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs b/hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs index 92775e1..1475c5c 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs @@ -16,7 +16,7 @@ import Network.Curl.Aeson (curlAesonGet, CurlAesonException) import Network.HTTP.Base (urlEncode) import System.Log.Logger.TH (deriveLoggers) -import Network.IRC.Types +import Network.IRC $(deriveLoggers "HSL" [HSL.ERROR]) @@ -25,10 +25,9 @@ songSearchMsgHandlerMaker = MsgHandlerMaker "songsearch" go where helpMsg = "Search for song. !m or !m - " - go _ _ "songsearch" = - return . Just $ newMsgHandler { onMessage = songSearch, - onHelp = return $ singletonMap "!m" helpMsg } - go _ _ _ = return Nothing + go _ _ = + return $ newMsgHandler { onMessage = songSearch + , handlerHelp = return $ singletonMap "!m" helpMsg } data Song = NoSong | Song { url :: Text, name :: Text, artist :: Text } deriving (Show, Eq) @@ -38,15 +37,15 @@ instance FromJSON Song where parseJSON a | a == emptyArray = return NoSong parseJSON _ = mempty -songSearch :: MonadMsgHandler m => FullMessage -> m [Command] -songSearch FullMessage { .. } +songSearch :: MonadMsgHandler m => Message -> m [Message] +songSearch Message { .. } | Just (ChannelMsg _ msg) <- fromMessage message , "!m " `isPrefixOf` msg = do BotConfig { .. } <- ask liftIO $ do let query = strip . drop 3 $ msg - mApiKey <- CF.lookup config "songsearch.tinysong_apikey" - map (singleton . toCommand . ChannelMsgReply) $ case mApiKey of + mApiKey <- CF.lookup config "songsearch.tinysong_apikey" + reply <- map ChannelMsgReply $ case mApiKey of Nothing -> do errorM "tinysong api key not found in config" return $ "Error while searching for " ++ query @@ -62,4 +61,5 @@ songSearch FullMessage { .. } Right song -> return $ case song of Song { .. } -> "Listen to " ++ artist ++ " - " ++ name ++ " at " ++ url NoSong -> "No song found for: " ++ query + map singleton . newMessage $ reply | otherwise = return [] diff --git a/hask-irc-handlers/Network/IRC/Handlers/Tell.hs b/hask-irc-handlers/Network/IRC/Handlers/Tell.hs index 52ee1b7..1b7acd4 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/Tell.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/Tell.hs @@ -6,19 +6,18 @@ module Network.IRC.Handlers.Tell (tellMsgHandlerMaker) where import qualified Data.IxSet as IS -import ClassyPrelude hiding (swap) -import Control.Concurrent.Lifted (Chan) -import Control.Monad.Reader (ask) -import Control.Monad.State (get, put) -import Data.Acid (AcidState, Query, Update, makeAcidic, query, update, - openLocalState, createArchive) -import Data.Acid.Local (createCheckpointAndClose) -import Data.IxSet ((@=)) -import Data.Text (split, strip) +import ClassyPrelude hiding (swap) +import Control.Monad.Reader (ask) +import Control.Monad.State (get, put) +import Data.Acid (AcidState, Query, Update, makeAcidic, query, update, + openLocalState, createArchive) +import Data.Acid.Local (createCheckpointAndClose) +import Data.IxSet ((@=)) +import Data.Text (split, strip) +import Network.IRC import Network.IRC.Handlers.NickTracker.Types import Network.IRC.Handlers.Tell.Internal.Types -import Network.IRC.Types import Network.IRC.Util -- database @@ -47,8 +46,8 @@ saveTell acid = update acid . SaveTellQ newtype TellState = TellState { acid :: AcidState Tells } -tellMsg :: MonadMsgHandler m => Chan Event -> IORef TellState -> FullMessage -> m [Command] -tellMsg eventChan state FullMessage { .. } +tellMsg :: MonadMsgHandler m => MessageChannel Message -> IORef TellState -> Message -> m [Message] +tellMsg messageChannel state Message { .. } | Just (ChannelMsg (User { .. }) msg) <- fromMessage message , command msg == "!tell" , args <- drop 1 . words $ msg @@ -61,7 +60,7 @@ tellMsg eventChan state FullMessage { .. } if null tell then return [] else do - res <- forM nicks $ \nick -> handleTell acid nick tell + res <- forM nicks $ \nick -> handleTell acid userNick nick tell let (fails, passes) = partitionEithers res let reps = (if null fails then [] else ["Unknown nicks: " ++ intercalate ", " fails]) ++ (if null passes then [] else @@ -73,22 +72,26 @@ tellMsg eventChan state FullMessage { .. } if null tell then return [] else do - res <- handleTell acid nick tell + res <- handleTell acid userNick nick tell let rep = case res of Left _ -> "Unknown nick: " ++ nickToText nick Right _ -> "Message noted and will be passed on to " ++ nickToText nick return [rep] tells <- getTellsToDeliver userNick - return . map (textToReply userNick) $ (reps ++ tells) - | Just (ChannelMsg (User { .. }) _) <- fromMessage message = - io $ map (map (textToReply userNick)) $ getTellsToDeliver userNick + mapM (textToReply userNick) (reps ++ tells) + | Just (ChannelMsg (User { .. }) _) <- fromMessage message = io $ do + tells <- getTellsToDeliver userNick + mapM (textToReply userNick) tells + | Just (TellRequest user msg) <- fromMessage message = do + tellMsg messageChannel state . Message msgTime "" . toMessage $ ChannelMsg user msg + return [] | otherwise = return [] where command msg = clean . fromMaybe "" . headMay . words $ msg parseNicks = ordNub . map Nick . filter (not . null) . split (\x -> x == ' ' || x == ',') - textToReply nick t = toCommand . ChannelMsgReply $ nickToText nick ++ ": " ++ t + textToReply nick t = newMessage . ChannelMsgReply $ nickToText nick ++ ": " ++ t tellToMsg Tell { .. } = relativeTime tellCreatedOn msgTime ++ " " ++ nickToText tellFromNick ++ " said: " ++ tellContent @@ -97,7 +100,7 @@ tellMsg eventChan state FullMessage { .. } getTellsToDeliver nick = io $ do TellState { .. } <- readIORef state - mcn <- getCanonicalNick eventChan nick + mcn <- getCanonicalNick messageChannel nick case mcn of Nothing -> return [] Just canonicalNick -> do @@ -106,19 +109,12 @@ tellMsg eventChan state FullMessage { .. } saveTell acid tell{ tellStatus = DeliveredTell, tellDeliveredOn = Just msgTime } return . tellToMsg $ tell - handleTell acid nick tell = do - mcn <- getCanonicalNick eventChan nick + handleTell acid userNick nick tell = do + mcn <- getCanonicalNick messageChannel nick case mcn of Nothing -> return . Left . nickToText $ nick Just canonicalNick -> - saveTell acid (newTell nick canonicalNick tell) >> (return . Right . nickToText $ nick) - -tellEvent :: MonadMsgHandler m => Chan Event -> IORef TellState -> Event -> m EventResponse -tellEvent eventChan state event = case fromEvent event of - Just (TellRequest user message, evTime) -> do - tellMsg eventChan state . FullMessage evTime "" . toMessage $ ChannelMsg user message - return RespNothing - _ -> return RespNothing + saveTell acid (newTell userNick canonicalNick tell) >> (return . Right . nickToText $ nick) stopTell :: MonadMsgHandler m => IORef TellState -> m () stopTell state = io $ do @@ -129,15 +125,13 @@ stopTell state = io $ do tellMsgHandlerMaker :: MsgHandlerMaker tellMsgHandlerMaker = MsgHandlerMaker "tell" go where - go BotConfig { .. } eventChan "tell" = do + go BotConfig { .. } messageChannel = do acid <- openLocalState emptyTells state <- newIORef (TellState acid) - return . Just $ newMsgHandler { onMessage = tellMsg eventChan state - , onEvent = tellEvent eventChan state - , onStop = stopTell state - , onHelp = return helpMsgs } - go _ _ _ = return Nothing + return $ newMsgHandler { onMessage = tellMsg messageChannel state + , onStop = stopTell state + , handlerHelp = return helpMsgs } helpMsgs = singletonMap "!tell" $ - "Publically passes a message to a user or a bunch of users. " ++ + "Publically pass a message to a user or a bunch of users. " ++ "!tell or !tell < ...> ." diff --git a/hask-irc-handlers/Network/IRC/Handlers/Tell/Internal/Types.hs b/hask-irc-handlers/Network/IRC/Handlers/Tell/Internal/Types.hs index 3021da6..c570bb8 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/Tell/Internal/Types.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/Tell/Internal/Types.hs @@ -4,27 +4,26 @@ module Network.IRC.Handlers.Tell.Internal.Types where import ClassyPrelude -import Control.Concurrent.Lifted (Chan, writeChan) -import Data.Data (Data) -import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun) -import Data.SafeCopy (base, deriveSafeCopy) +import Data.Data (Data) +import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun) +import Data.SafeCopy (base, deriveSafeCopy) +import Network.IRC import Network.IRC.Handlers.NickTracker.Types -import Network.IRC.Types newtype TellId = TellId Int deriving (Eq, Ord, Show, Data, Typeable, Num) data TellStatus = NewTell | DeliveredTell deriving (Eq, Ord, Show, Data, Typeable) -data Tell = Tell { - tellId :: !TellId, - tellFromNick :: !Nick, - tellToNick :: !CanonicalNick, - tellTopic :: !(Maybe Text), - tellStatus :: !TellStatus, - tellCreatedOn :: !UTCTime, - tellDeliveredOn :: !(Maybe UTCTime), - tellContent :: !Text -} deriving (Eq, Ord, Show, Data, Typeable) +data Tell = Tell + { tellId :: !TellId + , tellFromNick :: !Nick + , tellToNick :: !CanonicalNick + , tellTopic :: !(Maybe Text) + , tellStatus :: !TellStatus + , tellCreatedOn :: !UTCTime + , tellDeliveredOn :: !(Maybe UTCTime) + , tellContent :: !Text + } deriving (Eq, Ord, Show, Data, Typeable) instance Indexable Tell where empty = ixSet [ ixFun $ (: []) . tellId @@ -42,13 +41,14 @@ $(deriveSafeCopy 0 'base ''Tells) emptyTells :: Tells emptyTells = Tells (TellId 1) empty -data TellRequest = TellRequest User Text deriving (Eq, Typeable) +data TellRequest = TellRequest User Text deriving (Eq, Typeable, Ord) -instance EventC TellRequest +instance MessageC TellRequest instance Show TellRequest where show (TellRequest user tell) = "TellRequest[" ++ unpack (nickToText (userNick user) ++ ": " ++ tell) ++ "]" -sendTell :: Chan Event -> User -> Text -> IO () -sendTell eventChan user tell = toEvent (TellRequest user tell) >>= writeChan eventChan +sendTell :: MessageChannel Message -> User -> Text -> IO () +sendTell messageChannel user tell = + newMessage (TellRequest user tell) >>= sendMessage messageChannel diff --git a/hask-irc-runner/Main.hs b/hask-irc-runner/Main.hs index 126545e..bc40fbf 100644 --- a/hask-irc-runner/Main.hs +++ b/hask-irc-runner/Main.hs @@ -4,7 +4,7 @@ import ClassyPrelude hiding (getArgs) import System.Environment (getArgs, getProgName) import System.Exit (exitFailure) -import Network.IRC.Client +import Network.IRC import Network.IRC.Config main :: IO () diff --git a/hask-irc-runner/Network/IRC/Config.hs b/hask-irc-runner/Network/IRC/Config.hs index 3b2569c..99b7eeb 100644 --- a/hask-irc-runner/Network/IRC/Config.hs +++ b/hask-irc-runner/Network/IRC/Config.hs @@ -7,8 +7,8 @@ import qualified Data.Configurator as CF import ClassyPrelude import Data.Configurator.Types (Configured (..), Value (List), ConfigError (..), KeyError (..)) +import Network.IRC import Network.IRC.Handlers -import Network.IRC.Types instance Configured a => Configured [a] where convert (List xs) = Just . mapMaybe convert $ xs @@ -19,10 +19,14 @@ loadBotConfig configFile = do eConfig <- try $ CF.load [CF.Required configFile] case eConfig of Left (ParseError _ _) -> error "Error while loading config" - Right config -> do + Right config -> do eBotConfig <- try $ do handlers :: [Text] <- CF.require config "msghandlers" - let handlerInfo = foldl' (\m h -> insertMap h mempty m) mempty handlers + let handlerInfo = foldl' (\m h -> insertMap h mempty m) mempty handlers + let handlerMakers = foldl' (\m maker -> insertMap (msgHandlerName maker) maker m) mempty + . filter (\MsgHandlerMaker { .. } -> msgHandlerName `member` handlerInfo) + $ allMsgHandlerMakers + botConfig <- newBotConfig <$> CF.require config "server" <*> CF.require config "port" <*> @@ -30,7 +34,7 @@ loadBotConfig configFile = do (Nick <$> CF.require config "nick") <*> CF.require config "timeout" return botConfig { msgHandlerInfo = handlerInfo - , msgHandlerMakers = allMsgHandlerMakers + , msgHandlerMakers = handlerMakers , config = config }