Added docs to core project, some refactoring, updated dependencies
parent
5b28bdbe3e
commit
85cb92f1a0
|
@ -3,7 +3,7 @@ port = 6667
|
||||||
channel = "#testtesttest"
|
channel = "#testtesttest"
|
||||||
nick = "haskman"
|
nick = "haskman"
|
||||||
timeout = 130
|
timeout = 130
|
||||||
msghandlers = ["greeter", "welcomer", "messagelogger", "songsearch", "auth", "nicktracker"]
|
msghandlers = ["greeter", "welcomer", "messagelogger", "songsearch", "auth", "nicktracker", "tell"]
|
||||||
|
|
||||||
songsearch {
|
songsearch {
|
||||||
tinysong_apikey = "xxxyyyzzz"
|
tinysong_apikey = "xxxyyyzzz"
|
||||||
|
|
|
@ -25,8 +25,8 @@ import System.IO (hIsEOF)
|
||||||
import System.Timeout (timeout)
|
import System.Timeout (timeout)
|
||||||
import System.Log.Logger.TH (deriveLoggers)
|
import System.Log.Logger.TH (deriveLoggers)
|
||||||
|
|
||||||
|
import Network.IRC.Internal.Types
|
||||||
import Network.IRC.Protocol
|
import Network.IRC.Protocol
|
||||||
import Network.IRC.Types
|
|
||||||
import Network.IRC.Util
|
import Network.IRC.Util
|
||||||
|
|
||||||
$(deriveLoggers "HSL" [HSL.DEBUG, HSL.INFO, HSL.ERROR])
|
$(deriveLoggers "HSL" [HSL.DEBUG, HSL.INFO, HSL.ERROR])
|
||||||
|
@ -52,7 +52,7 @@ sendCommandLoop (commandChan, latch) bot@Bot { .. } = do
|
||||||
handle (\(e :: SomeException) ->
|
handle (\(e :: SomeException) ->
|
||||||
errorM ("Error while writing to connection: " ++ show e) >> latchIt latch) $ do
|
errorM ("Error while writing to connection: " ++ show e) >> latchIt latch) $ do
|
||||||
whenJust mline $ \line -> do
|
whenJust mline $ \line -> do
|
||||||
TF.hprint socket "{}\r\n" $ TF.Only line
|
TF.hprint botSocket "{}\r\n" $ TF.Only line
|
||||||
infoM . unpack $ "> " ++ line
|
infoM . unpack $ "> " ++ line
|
||||||
case cmd of
|
case cmd of
|
||||||
QuitCmd -> latchIt latch
|
QuitCmd -> latchIt latch
|
||||||
|
@ -87,11 +87,11 @@ readLineLoop = go []
|
||||||
go msgParts'' mvBotStatus (lineChan, latch) bot timeoutDelay
|
go msgParts'' mvBotStatus (lineChan, latch) bot timeoutDelay
|
||||||
where
|
where
|
||||||
readLine' = do
|
readLine' = do
|
||||||
eof <- hIsEOF socket
|
eof <- hIsEOF botSocket
|
||||||
if eof
|
if eof
|
||||||
then return EOF
|
then return EOF
|
||||||
else mask $ \unmask -> do
|
else mask $ \unmask -> do
|
||||||
line <- map initEx . unmask $ hGetLine socket
|
line <- map initEx . unmask $ hGetLine botSocket
|
||||||
infoM . unpack $ "< " ++ line
|
infoM . unpack $ "< " ++ line
|
||||||
now <- getCurrentTime
|
now <- getCurrentTime
|
||||||
return $ Line now line
|
return $ Line now line
|
||||||
|
@ -157,8 +157,8 @@ eventProcessLoop (eventChan, latch) lineChan commandChan bot@Bot {.. } = do
|
||||||
errorM $ "Exception while processing event: " ++ show ex) $ do
|
errorM $ "Exception while processing event: " ++ show ex) $ do
|
||||||
resp <- handleEvent msgHandler botConfig event
|
resp <- handleEvent msgHandler botConfig event
|
||||||
case resp of
|
case resp of
|
||||||
RespMessage message -> sendMessage lineChan message
|
RespMessage messages -> forM_ messages $ sendMessage lineChan
|
||||||
RespCommand command -> sendCommand commandChan command
|
RespCommand commands -> forM_ commands $ sendCommand commandChan
|
||||||
RespEvent event' -> sendEvent eventChan event'
|
RespEvent events -> forM_ events $ sendEvent eventChan
|
||||||
_ -> return ()
|
_ -> return ()
|
||||||
eventProcessLoop (eventChan, latch) lineChan commandChan bot
|
eventProcessLoop (eventChan, latch) lineChan commandChan bot
|
||||||
|
|
|
@ -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 #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
|
||||||
module Network.IRC.Client (runBot) where
|
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.Log.Logger.TH (deriveLoggers)
|
||||||
import System.Posix.Signals (installHandler, sigINT, sigTERM, Handler (Catch))
|
import System.Posix.Signals (installHandler, sigINT, sigTERM, Handler (Catch))
|
||||||
|
|
||||||
import Network.IRC.Bot
|
|
||||||
import qualified Network.IRC.Handlers.Core as Core
|
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
|
import Network.IRC.Util
|
||||||
|
|
||||||
$(deriveLoggers "HSL" [HSL.DEBUG, HSL.ERROR])
|
$(deriveLoggers "HSL" [HSL.DEBUG, HSL.ERROR])
|
||||||
|
@ -80,7 +91,7 @@ disconnect (Bot { .. }, mvBotStatus, (_, readLatch), (commandChan, sendLatch), (
|
||||||
awaitLatch eventLatch
|
awaitLatch eventLatch
|
||||||
|
|
||||||
unloadMsgHandlers
|
unloadMsgHandlers
|
||||||
handle (\(_ :: SomeException) -> return ()) $ hClose socket
|
handle (\(_ :: SomeException) -> return ()) $ hClose botSocket
|
||||||
debugM "Disconnected"
|
debugM "Disconnected"
|
||||||
where
|
where
|
||||||
unloadMsgHandlers = forM_ (mapToList msgHandlers) $ \(msgHandlerName, msgHandler) -> do
|
unloadMsgHandlers = forM_ (mapToList msgHandlers) $ \(msgHandlerName, msgHandler) -> do
|
||||||
|
@ -122,7 +133,9 @@ runBotIntenal botConfig' = withSocketsDo $ do
|
||||||
fork $ eventProcessLoop eventChannel lineChan commandChan bot
|
fork $ eventProcessLoop eventChannel lineChan commandChan bot
|
||||||
runIRC bot Connected (messageProcessLoop lineChan commandChan)
|
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
|
runBot botConfig = do
|
||||||
-- setup signal handling
|
-- setup signal handling
|
||||||
mainThreadId <- myThreadId
|
mainThreadId <- myThreadId
|
||||||
|
|
|
@ -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
|
|
@ -1,222 +1,36 @@
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
{-|
|
||||||
{-# LANGUAGE ExistentialQuantification #-}
|
Module : Network.IRC.Types
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
Description : Types for the IRC bot and the message handlers.
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
Copyright : (c) Abhinav Sarkar, 2014
|
||||||
{-# LANGUAGE RankNTypes #-}
|
License : Apache-2.0
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
Maintainer : abhinav@abhinavsarkar.net
|
||||||
|
Stability : experimental
|
||||||
|
Portability : POSIX
|
||||||
|
-}
|
||||||
|
|
||||||
module Network.IRC.Types
|
module Network.IRC.Types
|
||||||
( Nick (..)
|
(
|
||||||
, MsgHandlerName
|
-- * IRC related
|
||||||
|
Nick (..)
|
||||||
, User (..)
|
, User (..)
|
||||||
, Message (..)
|
, Message (..)
|
||||||
, MessageDetails (..)
|
, MessageDetails (..)
|
||||||
, Command (..)
|
, Command (..)
|
||||||
|
-- * Events
|
||||||
, Event (..)
|
, Event (..)
|
||||||
, SomeEvent
|
, SomeEvent
|
||||||
, QuitEvent(..)
|
|
||||||
, EventResponse (..)
|
, EventResponse (..)
|
||||||
|
, QuitEvent(..)
|
||||||
|
-- * Bot
|
||||||
, BotConfig (..)
|
, BotConfig (..)
|
||||||
, BotStatus (..)
|
|
||||||
, Bot (..)
|
, Bot (..)
|
||||||
, IRC
|
, BotStatus (..)
|
||||||
, runIRC
|
-- * Message handlers
|
||||||
, MsgHandler (..)
|
, MsgHandlerName
|
||||||
, MonadMsgHandler
|
, MonadMsgHandler
|
||||||
|
, MsgHandler (..)
|
||||||
, newMsgHandler
|
, newMsgHandler
|
||||||
, handleMessage
|
, MsgHandlerMaker (..)
|
||||||
, handleEvent
|
) where
|
||||||
, stopMsgHandler
|
|
||||||
, getHelp
|
|
||||||
, MsgHandlerMaker (..))
|
|
||||||
where
|
|
||||||
|
|
||||||
import ClassyPrelude
|
import Network.IRC.Internal.Types
|
||||||
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
|
|
||||||
|
|
|
@ -1,4 +1,5 @@
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# OPTIONS_HADDOCK hide #-}
|
||||||
|
|
||||||
module Network.IRC.Util where
|
module Network.IRC.Util where
|
||||||
|
|
||||||
|
|
|
@ -60,22 +60,23 @@ library
|
||||||
hslogger >=1.2 && <1.3,
|
hslogger >=1.2 && <1.3,
|
||||||
hslogger-template >=2.0 && <2.1,
|
hslogger-template >=2.0 && <2.1,
|
||||||
lifted-base >=0.2 && <0.3,
|
lifted-base >=0.2 && <0.3,
|
||||||
mtl >=2.1 && <2.2,
|
mtl >=2.1 && <2.3,
|
||||||
network >=2.3 && <2.5,
|
network >=2.5 && <2.6,
|
||||||
safecopy >=0.8 && <0.9,
|
safecopy >=0.8 && <0.9,
|
||||||
text >=0.11 && <0.12,
|
text >=1.1 && <1.2,
|
||||||
text-format >=0.3 && <0.4,
|
text-format >=0.3 && <0.4,
|
||||||
time >=1.4 && <1.5,
|
time >=1.4 && <1.5,
|
||||||
transformers-base >=0.4 && <0.5,
|
transformers-base >=0.4 && <0.5,
|
||||||
unix >=2.7 && <2.8
|
unix >=2.7 && <2.8
|
||||||
|
|
||||||
exposed-modules: Network.IRC.Types,
|
exposed-modules: Network.IRC.Types,
|
||||||
Network.IRC.Protocol,
|
|
||||||
Network.IRC.Util,
|
|
||||||
Network.IRC.Bot,
|
|
||||||
Network.IRC.Client,
|
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
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
|
|
@ -31,9 +31,9 @@ getUndeliveredTellsQ nick = do
|
||||||
saveTellQ :: Tell -> Update Tells ()
|
saveTellQ :: Tell -> Update Tells ()
|
||||||
saveTellQ tell@Tell { .. } = do
|
saveTellQ tell@Tell { .. } = do
|
||||||
Tells { .. } <- get
|
Tells { .. } <- get
|
||||||
if tellId == -1
|
put $ if tellId == -1
|
||||||
then put $ Tells (nextTellId + 1) (IS.updateIx nextTellId tell{ tellId = nextTellId } tells)
|
then Tells (nextTellId + 1) (IS.updateIx nextTellId tell{ tellId = nextTellId } tells)
|
||||||
else put $ Tells nextTellId (IS.updateIx tellId tell tells)
|
else Tells nextTellId (IS.updateIx tellId tell tells)
|
||||||
|
|
||||||
$(makeAcidic ''Tells ['getUndeliveredTellsQ, 'saveTellQ])
|
$(makeAcidic ''Tells ['getUndeliveredTellsQ, 'saveTellQ])
|
||||||
|
|
||||||
|
@ -137,6 +137,6 @@ mkMsgHandler = MsgHandlerMaker "tell" go
|
||||||
, onHelp = return helpMsgs }
|
, onHelp = return helpMsgs }
|
||||||
go _ _ _ = return Nothing
|
go _ _ _ = return Nothing
|
||||||
|
|
||||||
helpMsgs = mapFromList [
|
helpMsgs = singletonMap "!tell" $
|
||||||
("!tell", "Publically passes a message to a user or a bunch of users. " ++
|
"Publically passes a message to a user or a bunch of users. " ++
|
||||||
"!tell <nick> <message> or !tell <<nick1> <nick2> ...> <message>.") ]
|
"!tell <nick> <message> or !tell <<nick1> <nick2> ...> <message>."
|
||||||
|
|
|
@ -56,7 +56,7 @@ library
|
||||||
build-depends: base >=4.5 && <4.8,
|
build-depends: base >=4.5 && <4.8,
|
||||||
hask-irc-core ==0.1.0,
|
hask-irc-core ==0.1.0,
|
||||||
acid-state >=0.12 && <0.13,
|
acid-state >=0.12 && <0.13,
|
||||||
aeson >=0.6.0.0 && <0.7,
|
aeson >=0.7 && <0.8,
|
||||||
classy-prelude >=0.9 && <1.0,
|
classy-prelude >=0.9 && <1.0,
|
||||||
configurator >=0.2 && <0.3,
|
configurator >=0.2 && <0.3,
|
||||||
convertible >=1.1 && <1.2,
|
convertible >=1.1 && <1.2,
|
||||||
|
@ -68,9 +68,9 @@ library
|
||||||
HTTP >=4000 && <5000,
|
HTTP >=4000 && <5000,
|
||||||
ixset >=1.0 && <1.1,
|
ixset >=1.0 && <1.1,
|
||||||
lifted-base >=0.2 && <0.3,
|
lifted-base >=0.2 && <0.3,
|
||||||
mtl >=2.1 && <2.2,
|
mtl >=2.1 && <2.3,
|
||||||
safecopy >=0.8 && <0.9,
|
safecopy >=0.8 && <0.9,
|
||||||
text >=0.11 && <0.12,
|
text >=1.1 && <1.2,
|
||||||
text-format >=0.3 && <0.4,
|
text-format >=0.3 && <0.4,
|
||||||
time >=1.4 && <1.5,
|
time >=1.4 && <1.5,
|
||||||
uuid >=1.3 && <1.4
|
uuid >=1.3 && <1.4
|
||||||
|
|
Loading…
Reference in New Issue