diff --git a/config.cfg.template b/config.cfg.template index 6af21a6..d553d25 100644 --- a/config.cfg.template +++ b/config.cfg.template @@ -3,7 +3,7 @@ port = 6667 channel = "#testtesttest" nick = "haskman" timeout = 130 -msghandlers = ["greeter", "welcomer", "messagelogger", "songsearch", "auth", "nicktracker"] +msghandlers = ["greeter", "welcomer", "messagelogger", "songsearch", "auth", "nicktracker", "tell"] songsearch { tinysong_apikey = "xxxyyyzzz" diff --git a/hask-irc-core/Network/IRC/Bot.hs b/hask-irc-core/Network/IRC/Bot.hs index a17931d..91b9d22 100644 --- a/hask-irc-core/Network/IRC/Bot.hs +++ b/hask-irc-core/Network/IRC/Bot.hs @@ -25,8 +25,8 @@ import System.IO (hIsEOF) import System.Timeout (timeout) import System.Log.Logger.TH (deriveLoggers) +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]) @@ -52,7 +52,7 @@ sendCommandLoop (commandChan, latch) bot@Bot { .. } = do handle (\(e :: SomeException) -> errorM ("Error while writing to connection: " ++ show e) >> latchIt latch) $ do whenJust mline $ \line -> do - TF.hprint socket "{}\r\n" $ TF.Only line + TF.hprint botSocket "{}\r\n" $ TF.Only line infoM . unpack $ "> " ++ line case cmd of QuitCmd -> latchIt latch @@ -87,11 +87,11 @@ readLineLoop = go [] go msgParts'' mvBotStatus (lineChan, latch) bot timeoutDelay where readLine' = do - eof <- hIsEOF socket + eof <- hIsEOF botSocket if eof then return EOF else mask $ \unmask -> do - line <- map initEx . unmask $ hGetLine socket + line <- map initEx . unmask $ hGetLine botSocket infoM . unpack $ "< " ++ line now <- getCurrentTime return $ Line now line @@ -157,8 +157,8 @@ eventProcessLoop (eventChan, latch) lineChan commandChan bot@Bot {.. } = do errorM $ "Exception while processing event: " ++ 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 () + 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 diff --git a/hask-irc-core/Network/IRC/Client.hs b/hask-irc-core/Network/IRC/Client.hs index d531592..a08fe71 100644 --- a/hask-irc-core/Network/IRC/Client.hs +++ b/hask-irc-core/Network/IRC/Client.hs @@ -1,3 +1,13 @@ +{-| +Module : Network.IRC.Client +Description : The IRC bot client used to create and run the bot. +Copyright : (c) Abhinav Sarkar, 2014 +License : Apache-2.0 +Maintainer : abhinav@abhinavsarkar.net +Stability : experimental +Portability : POSIX +-} + {-# LANGUAGE TemplateHaskell #-} module Network.IRC.Client (runBot) where @@ -17,9 +27,10 @@ import System.Log.Logger (Priority (..), updateGlobalLogger, rootLoggerN import System.Log.Logger.TH (deriveLoggers) import System.Posix.Signals (installHandler, sigINT, sigTERM, Handler (Catch)) -import Network.IRC.Bot import qualified Network.IRC.Handlers.Core as Core -import Network.IRC.Types + +import Network.IRC.Bot +import Network.IRC.Internal.Types import Network.IRC.Util $(deriveLoggers "HSL" [HSL.DEBUG, HSL.ERROR]) @@ -80,7 +91,7 @@ disconnect (Bot { .. }, mvBotStatus, (_, readLatch), (commandChan, sendLatch), ( awaitLatch eventLatch unloadMsgHandlers - handle (\(_ :: SomeException) -> return ()) $ hClose socket + handle (\(_ :: SomeException) -> return ()) $ hClose botSocket debugM "Disconnected" where unloadMsgHandlers = forM_ (mapToList msgHandlers) $ \(msgHandlerName, msgHandler) -> do @@ -122,7 +133,9 @@ runBotIntenal botConfig' = withSocketsDo $ do fork $ eventProcessLoop eventChannel lineChan commandChan bot runIRC bot Connected (messageProcessLoop lineChan commandChan) -runBot :: BotConfig -> IO () +-- | 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. + -> IO () runBot botConfig = do -- setup signal handling mainThreadId <- myThreadId diff --git a/hask-irc-core/Network/IRC/Internal/Types.hs b/hask-irc-core/Network/IRC/Internal/Types.hs new file mode 100644 index 0000000..55470ae --- /dev/null +++ b/hask-irc-core/Network/IRC/Internal/Types.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Network.IRC.Internal.Types + ( + -- * Messages and Commands + Nick (..) + , User (..) + , Message (..) + , MessageDetails (..) + , Command (..) + -- * Events + , Event (..) + , SomeEvent + , EventResponse (..) + , QuitEvent(..) + -- * Bot + , BotConfig (..) + , Bot (..) + , BotStatus (..) + , IRC + , runIRC + -- * Message handlers + , MsgHandlerName + , MonadMsgHandler + , MsgHandler (..) + , newMsgHandler + , MsgHandlerMaker (..) + , handleMessage + , handleEvent + , stopMsgHandler + , getHelp + ) where + +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 Data.Data (Data) +import Data.SafeCopy (base, deriveSafeCopy) +import Data.Typeable (cast) + +import Network.IRC.Util + +-- * Types +-- ** IRC related + +-- | An IRC nick. +newtype Nick = Nick { nickToText :: Text } + deriving (Eq, Ord, Data, Typeable, Hashable) + +instance Show Nick where + show = unpack . nickToText + +$(deriveSafeCopy 0 'base ''Nick) + +-- | An IRC user. +data User + -- | The user for the bot itself. + = Self + -- | An user other than the bot. + | User + { userNick :: !Nick -- ^ The user's nick. + , userServer :: !Text -- ^ The user's server. + } deriving (Show, Eq, Ord) + +-- | An IRC message sent from the server to the bot. +data Message = Message + { msgTime :: !UTCTime -- ^ The time when the message was received. + , msgLine :: !Text -- ^ The raw message line. + , msgDetails :: MessageDetails -- ^ The details of the parsed message. + } deriving (Show, Eq, Ord) + +-- | Different types of IRC messages. +data MessageDetails + -- | The internal (non-IRC) message received when the bot is idle. + = IdleMsg + -- | The message received when the bot's current nick is already in use. + | NickInUseMsg + -- | A /PING/ message. Must be replied with a 'PongCmd'. + | PingMsg { msg :: !Text } + -- | A /PONG/ message. Received in response to a 'PingCmd'. + | PongMsg { msg :: !Text } + -- | A /NAMES/ message which contains a list of nicks of all users in the channel. + | NamesMsg { nicks :: ![Nick] } + -- | A /PRIVMSG/ message sent to the channel from a user. + | ChannelMsg { user :: !User, msg :: !Text } + -- | A /PRIVMSG/ private message sent to the bot from a user. + | PrivMsg { user :: !User, msg :: !Text } + -- | An /PRIVMSG/ action message sent to the channel from a user. + | ActionMsg { user :: !User, msg :: !Text } + -- | A /JOIN/ message received when a user joins the channel. + | JoinMsg { user :: !User } + -- | A /QUIT/ message received when a user quits the server. + | QuitMsg { user :: !User, msg :: !Text } + -- | A /PART/ message received when a user leaves the channel. + | PartMsg { user :: !User, msg :: !Text } + -- | A /NICK/ message received when a user changes their nick. + | NickMsg { user :: !User, newNick :: !Nick } + -- | A /KICK/ message received when a user kicks another user from the channel. + | KickMsg { user :: !User, kickedNick :: !Nick, msg :: !Text } + -- | A /MODE/ message received when a user's mode changes. + | ModeMsg { user :: !User, msgTarget :: !Text, mode :: !Text , modeArgs :: ![Text] } + -- | All other messages which are not parsed as any of the above types. + | OtherMsg { msgSource :: !Text, msgCommand :: !Text, msgTarget :: !Text , msg :: !Text } + deriving (Show, Eq, Ord) + +-- | IRC commands sent from the bot to the server. +data Command + -- | A /PING/ command. A 'PongMsg' is expected as a response to this. + = PingCmd { rmsg :: !Text } + -- | A /PONG/ command. Sent in response to a 'PingMsg'. + | PongCmd { rmsg :: !Text } + -- | A /PRIVMSG/ message sent to the channel. + | ChannelMsgReply { rmsg :: !Text } + -- | A /PRIVMSG/ message sent to a user. + | PrivMsgReply { ruser :: !User, rmsg :: !Text } + -- | A /NICK/ command sent to set the bot's nick. + | NickCmd + -- | A /USER/ command sent to identify the bot. + | UserCmd + -- | A /JOIN/ command sent to join the channel. + | JoinCmd + -- | A /QUIT/ command sent to quit the server. + | QuitCmd + -- | A /NAMES/ command sent to ask for the nicks of the users in the channel. + | NamesCmd + deriving (Show, Eq, Ord) + +-- ** 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) => Event e where + -- | Creates an event. + toEvent :: e -> IO SomeEvent + toEvent e = SomeEvent <$> pure e <*> getCurrentTime + + -- | Extracts a received event. + fromEvent :: SomeEvent -> Maybe (e, UTCTime) + fromEvent (SomeEvent e time) = do + ev <- cast e + return (ev, time) + +-- | A wrapper over all events to allow sending them over channel of same type. +data SomeEvent = forall e. (Event e, Typeable e) => SomeEvent e UTCTime deriving (Typeable) +instance Show SomeEvent where + show (SomeEvent e time) = formatTime defaultTimeLocale "[%F %T] " time ++ show e +instance Eq SomeEvent where + SomeEvent e1 t1 == SomeEvent 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 + = RespNothing -- ^ No response + | RespEvent [SomeEvent] -- ^ Events as the response. They will be sent to all message handlers like usual events. + | RespMessage [Message] -- ^ Messages as the response. They will be sent to all message handlers like usual messages. + | RespCommand [Command] -- ^ Commands as the response. They will be sent to the server like usual commands. + deriving (Show, Eq) + +-- | An event signifying the bot quitting the server. +data QuitEvent = QuitEvent deriving (Show, Eq, Ord, Typeable) +instance Event QuitEvent + +-- ** Bot + +-- | Name of a message handler. +type MsgHandlerName = Text + +-- | The configuration for running the bot. +data BotConfig = BotConfig + { + -- | The server to connect to. + server :: !Text + -- | The port to connect to. + , port :: !Int + -- | The channel to join. + , channel :: !Text + -- | Nick of the bot. + , botNick :: !Nick + -- | The timeout in seconds after which bot automatically disconnects and tries to reconnect. + -- Should be few seconds more than the ping timeout of the server. + , botTimeout :: !Int + -- | Info about the message handlers. A map of message handler names to a map of all commands supported + -- 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] + -- | All the bot configuration so that message handlers can lookup their own specific configs. + , config :: !Config + } + +instance Show BotConfig where + show 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) + +-- | The bot. +data Bot = Bot + { + -- | The config for the bot. + botConfig :: !BotConfig + -- | The network socket on which the bot communicates with the server. + , botSocket :: !Handle + -- | The message handlers attached with the bot as a map of message handler names to the message handlers. + , msgHandlers :: !(Map MsgHandlerName MsgHandler) + } + +-- | 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. + deriving (Show, Eq, Ord) + +-- | An IRC action to be run. +newtype IRC a = IRC { _runIRC :: StateT BotStatus (ReaderT Bot IO) a } + deriving ( Functor + , Applicative + , Monad + , MonadIO + , MonadReader Bot + , MonadState BotStatus + ) + +-- | Runs the bot action. +runIRC :: Bot -- ^ The bot. + -> BotStatus -- ^ The bot status. + -> IRC a -- ^ The bot action to run. + -> IO BotStatus -- ^ IO action which returns the next bot status. +runIRC bot botStatus = flip runReaderT bot . flip execStateT botStatus . _runIRC + +-- ** Message handlers + +newtype MsgHandlerT a = MsgHandlerT { _runMsgHandler :: ReaderT BotConfig IO a } + deriving ( Functor + , Applicative + , Monad + , MonadIO + , MonadBase IO + , MonadReader BotConfig + ) + +-- | The monad in which message handlers actions run. +class (MonadIO m, Applicative m, MonadReader BotConfig m, MonadBase IO m) => MonadMsgHandler m where + msgHandler :: MsgHandlerT a -> m a + +instance MonadMsgHandler MsgHandlerT where + msgHandler = id + +-- | A message handler containing actions which are invoked by the bot. +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 => Message -> 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 => SomeEvent -> m EventResponse) + -- | The action invoked to stop the message handler. + , 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)) + } + +-- | 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 + } + +-- | A message handler maker which creates a new message handler. +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 SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)) + } + +instance Eq MsgHandlerMaker where + m1 == m2 = msgHandlerName m1 == msgHandlerName m2 +instance Ord MsgHandlerMaker where + m1 `compare` m2 = msgHandlerName m1 `compare` msgHandlerName m2 + +-- | Handles a message using a given message handler. +handleMessage :: MsgHandler -- ^ The message handler. + -> BotConfig -- ^ The bot config. + -> Message -- ^ The message to handle. + -> IO [Command] -- ^ 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. + -> SomeEvent -- ^ 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. + -> IO () +stopMsgHandler MsgHandler { .. } botConfig = + flip runReaderT botConfig . _runMsgHandler $ onStop + +-- | Gets the help messages for a given message handler. +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 diff --git a/hask-irc-core/Network/IRC/Types.hs b/hask-irc-core/Network/IRC/Types.hs index dc65d81..97e9f40 100644 --- a/hask-irc-core/Network/IRC/Types.hs +++ b/hask-irc-core/Network/IRC/Types.hs @@ -1,222 +1,36 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} +{-| +Module : Network.IRC.Types +Description : Types for the IRC bot and the message handlers. +Copyright : (c) Abhinav Sarkar, 2014 +License : Apache-2.0 +Maintainer : abhinav@abhinavsarkar.net +Stability : experimental +Portability : POSIX +-} module Network.IRC.Types - ( Nick (..) - , MsgHandlerName + ( + -- * IRC related + Nick (..) , User (..) , Message (..) , MessageDetails (..) , Command (..) + -- * Events , Event (..) , SomeEvent - , QuitEvent(..) , EventResponse (..) + , QuitEvent(..) + -- * Bot , BotConfig (..) - , BotStatus (..) , Bot (..) - , IRC - , runIRC - , MsgHandler (..) + , BotStatus (..) + -- * Message handlers + , MsgHandlerName , MonadMsgHandler + , MsgHandler (..) , newMsgHandler - , handleMessage - , handleEvent - , stopMsgHandler - , getHelp - , MsgHandlerMaker (..)) -where + , MsgHandlerMaker (..) + ) where -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 Data.Data (Data) -import Data.SafeCopy (base, deriveSafeCopy) -import Data.Typeable (cast) - -import Network.IRC.Util - --- IRC related - -newtype Nick = Nick { nickToText :: Text } - deriving (Eq, Ord, Data, Typeable, Hashable) - -instance Show Nick where - show = unpack . nickToText - -$(deriveSafeCopy 0 'base ''Nick) - -data User = Self | User { userNick :: !Nick, userServer :: !Text } - deriving (Show, Eq, Ord) - -data Message = Message { msgTime :: !UTCTime, msgLine :: !Text, msgDetails :: MessageDetails} - deriving (Show, Eq, Ord) - -data MessageDetails = - IdleMsg - | NickInUseMsg - | PingMsg { msg :: !Text } - | PongMsg { msg :: !Text } - | NamesMsg { nicks :: ![Nick] } - | ChannelMsg { user :: !User, msg :: !Text } - | PrivMsg { user :: !User, msg :: !Text } - | ActionMsg { user :: !User, msg :: !Text } - | JoinMsg { user :: !User } - | QuitMsg { user :: !User, msg :: !Text } - | PartMsg { user :: !User, msg :: !Text } - | NickMsg { user :: !User, newNick :: !Nick } - | KickMsg { user :: !User, kickedNick :: !Nick, msg :: !Text } - | ModeMsg { user :: !User, msgTarget :: !Text, mode :: !Text , modeArgs :: ![Text] } - | OtherMsg { msgSource :: !Text, msgCommand :: !Text, msgTarget :: !Text , msg :: !Text } - deriving (Show, Eq, Ord) - -data Command = - PingCmd { rmsg :: !Text } - | PongCmd { rmsg :: !Text } - | ChannelMsgReply { rmsg :: !Text } - | PrivMsgReply { ruser :: !User, rmsg :: !Text } - | NickCmd - | UserCmd - | JoinCmd - | QuitCmd - | NamesCmd - deriving (Show, Eq, Ord) - --- Events - -class (Typeable e, Show e, Eq 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, Typeable e) => SomeEvent e UTCTime deriving (Typeable) -instance Show SomeEvent where - show (SomeEvent e time) = formatTime defaultTimeLocale "[%F %T] " time ++ show e -instance Eq SomeEvent where - SomeEvent e1 t1 == SomeEvent e2 t2 = - case cast e2 of - Just e2' -> e1 == e2' && t1 == t2 - Nothing -> False - -data QuitEvent = QuitEvent deriving (Show, Eq, Ord, Typeable) -instance Event QuitEvent - -data EventResponse = RespNothing - | RespEvent SomeEvent - | RespMessage Message - | RespCommand Command - deriving (Show, Eq) - --- Bot - -type MsgHandlerName = Text - -data BotConfig = BotConfig { server :: !Text - , port :: !Int - , channel :: !Text - , botNick :: !Nick - , botTimeout :: !Int - , msgHandlerInfo :: !(Map MsgHandlerName (Map Text Text)) - , msgHandlerMakers :: ![MsgHandlerMaker] - , config :: !Config } - -instance Show BotConfig where - show 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) - -data Bot = Bot { botConfig :: !BotConfig - , socket :: !Handle - , msgHandlers :: !(Map MsgHandlerName MsgHandler) } - -data BotStatus = Connected - | Disconnected - | Joined - | Kicked - | Errored - | Idle - | Interrupted - | NickNotAvailable - deriving (Show, Eq, Ord) - -newtype IRC a = IRC { _runIRC :: StateT BotStatus (ReaderT Bot IO) a } - deriving ( Functor - , Applicative - , Monad - , MonadIO - , MonadReader Bot - , MonadState BotStatus ) - -runIRC :: Bot -> BotStatus -> IRC a -> IO BotStatus -runIRC bot botStatus = flip runReaderT bot . flip execStateT botStatus . _runIRC - --- Message handlers - -newtype MsgHandlerT a = MsgHandlerT { _runMsgHandler :: ReaderT BotConfig IO a } - deriving ( Functor - , Applicative - , Monad - , MonadIO - , MonadBase IO - , MonadReader BotConfig ) - -class (MonadIO m, Applicative m, MonadReader BotConfig m, MonadBase IO m) => MonadMsgHandler m where - msgHandler :: MsgHandlerT a -> m a - -instance MonadMsgHandler MsgHandlerT where - msgHandler = id - -handleMessage :: MsgHandler -> BotConfig -> Message -> IO [Command] -handleMessage MsgHandler { .. } botConfig = - flip runReaderT botConfig . _runMsgHandler . onMessage - -stopMsgHandler :: MsgHandler -> BotConfig -> IO () -stopMsgHandler MsgHandler { .. } botConfig = - flip runReaderT botConfig . _runMsgHandler $ onStop - -handleEvent :: MsgHandler -> BotConfig -> SomeEvent -> IO EventResponse -handleEvent MsgHandler { .. } botConfig = - flip runReaderT botConfig . _runMsgHandler . onEvent - -getHelp :: MsgHandler -> BotConfig -> IO (Map Text Text) -getHelp MsgHandler { .. } botConfig = - flip runReaderT botConfig . _runMsgHandler $ onHelp - -data MsgHandler = MsgHandler { - onMessage :: !(forall m . MonadMsgHandler m => Message -> m [Command]), - onStop :: !(forall m . MonadMsgHandler m => m ()), - onEvent :: !(forall m . MonadMsgHandler m => SomeEvent -> m EventResponse), - onHelp :: !(forall m . MonadMsgHandler m => m (Map Text Text)) -} - -newMsgHandler :: MsgHandler -newMsgHandler = MsgHandler { - onMessage = const $ return [], - onStop = return (), - onEvent = const $ return RespNothing, - onHelp = return mempty -} - -data MsgHandlerMaker = MsgHandlerMaker { - msgHandlerName :: !MsgHandlerName, - msgHandlerMaker :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler) -} - -instance Eq MsgHandlerMaker where - m1 == m2 = msgHandlerName m1 == msgHandlerName m2 -instance Ord MsgHandlerMaker where - m1 `compare` m2 = msgHandlerName m1 `compare` msgHandlerName m2 +import Network.IRC.Internal.Types diff --git a/hask-irc-core/Network/IRC/Util.hs b/hask-irc-core/Network/IRC/Util.hs index a4dbeb3..8ac0ffc 100644 --- a/hask-irc-core/Network/IRC/Util.hs +++ b/hask-irc-core/Network/IRC/Util.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_HADDOCK hide #-} module Network.IRC.Util where diff --git a/hask-irc-core/hask-irc-core.cabal b/hask-irc-core/hask-irc-core.cabal index fbdc84a..f32ec38 100644 --- a/hask-irc-core/hask-irc-core.cabal +++ b/hask-irc-core/hask-irc-core.cabal @@ -60,22 +60,23 @@ library hslogger >=1.2 && <1.3, hslogger-template >=2.0 && <2.1, lifted-base >=0.2 && <0.3, - mtl >=2.1 && <2.2, - network >=2.3 && <2.5, + mtl >=2.1 && <2.3, + network >=2.5 && <2.6, safecopy >=0.8 && <0.9, - text >=0.11 && <0.12, + text >=1.1 && <1.2, text-format >=0.3 && <0.4, time >=1.4 && <1.5, transformers-base >=0.4 && <0.5, unix >=2.7 && <2.8 exposed-modules: Network.IRC.Types, - Network.IRC.Protocol, - Network.IRC.Util, - Network.IRC.Bot, Network.IRC.Client, - Network.IRC.Handlers.Core + Network.IRC.Util + other-modules: Network.IRC.Internal.Types, + Network.IRC.Protocol, + Network.IRC.Bot, + Network.IRC.Handlers.Core default-language: Haskell2010 diff --git a/hask-irc-handlers/Network/IRC/Handlers/Tell.hs b/hask-irc-handlers/Network/IRC/Handlers/Tell.hs index 337ce0c..23a0b24 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/Tell.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/Tell.hs @@ -31,9 +31,9 @@ getUndeliveredTellsQ nick = do saveTellQ :: Tell -> Update Tells () saveTellQ tell@Tell { .. } = do Tells { .. } <- get - if tellId == -1 - then put $ Tells (nextTellId + 1) (IS.updateIx nextTellId tell{ tellId = nextTellId } tells) - else put $ Tells nextTellId (IS.updateIx tellId tell tells) + put $ if tellId == -1 + then Tells (nextTellId + 1) (IS.updateIx nextTellId tell{ tellId = nextTellId } tells) + else Tells nextTellId (IS.updateIx tellId tell tells) $(makeAcidic ''Tells ['getUndeliveredTellsQ, 'saveTellQ]) @@ -137,6 +137,6 @@ mkMsgHandler = MsgHandlerMaker "tell" go , onHelp = return helpMsgs } go _ _ _ = return Nothing - helpMsgs = mapFromList [ - ("!tell", "Publically passes a message to a user or a bunch of users. " ++ - "!tell or !tell < ...> .") ] + helpMsgs = singletonMap "!tell" $ + "Publically passes a message to a user or a bunch of users. " ++ + "!tell or !tell < ...> ." diff --git a/hask-irc-handlers/hask-irc-handlers.cabal b/hask-irc-handlers/hask-irc-handlers.cabal index f933682..74d3941 100644 --- a/hask-irc-handlers/hask-irc-handlers.cabal +++ b/hask-irc-handlers/hask-irc-handlers.cabal @@ -56,7 +56,7 @@ library build-depends: base >=4.5 && <4.8, hask-irc-core ==0.1.0, acid-state >=0.12 && <0.13, - aeson >=0.6.0.0 && <0.7, + aeson >=0.7 && <0.8, classy-prelude >=0.9 && <1.0, configurator >=0.2 && <0.3, convertible >=1.1 && <1.2, @@ -68,9 +68,9 @@ library HTTP >=4000 && <5000, ixset >=1.0 && <1.1, lifted-base >=0.2 && <0.3, - mtl >=2.1 && <2.2, + mtl >=2.1 && <2.3, safecopy >=0.8 && <0.9, - text >=0.11 && <0.12, + text >=1.1 && <1.2, text-format >=0.3 && <0.4, time >=1.4 && <1.5, uuid >=1.3 && <1.4