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

Added docs to core project, some refactoring, updated dependencies

Browse Source
This commit is contained in:
Abhinav Sarkar 2014-06-06 19:58:53 +05:30
parent 5b28bdbe3e
commit 85cb92f1a0
9 changed files with 400 additions and 237 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
config.cfg.template
View File

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

16
hask-irc-core/Network/IRC/Bot.hs
View File

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

21
hask-irc-core/Network/IRC/Client.hs
View File

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

334
hask-irc-core/Network/IRC/Internal/Types.hs Normal file
View File

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

230
hask-irc-core/Network/IRC/Types.hs
View File

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

1
hask-irc-core/Network/IRC/Util.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_HADDOCK hide #-}
module Network.IRC.Util where

15
hask-irc-core/hask-irc-core.cabal
View File

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

12
hask-irc-handlers/Network/IRC/Handlers/Tell.hs
View File

@ -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 <nick> <message> or !tell <<nick1> <nick2> ...> <message>.") ]
helpMsgs = singletonMap "!tell" $
"Publically passes a message to a user or a bunch of users. " ++
"!tell <nick> <message> or !tell <<nick1> <nick2> ...> <message>."

6
hask-irc-handlers/hask-irc-handlers.cabal
View File

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