Some restructuring and refactoring
parent
5d49e4e201
commit
e61cab74ed
|
@ -27,6 +27,7 @@ import System.Log.Logger.TH (deriveLoggers)
|
||||||
|
|
||||||
import Network.IRC.Internal.Types
|
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])
|
||||||
|
|
|
@ -31,6 +31,7 @@ import qualified Network.IRC.Handlers.Core as Core
|
||||||
|
|
||||||
import Network.IRC.Bot
|
import Network.IRC.Bot
|
||||||
import Network.IRC.Internal.Types
|
import Network.IRC.Internal.Types
|
||||||
|
import Network.IRC.Types
|
||||||
import Network.IRC.Util
|
import Network.IRC.Util
|
||||||
|
|
||||||
$(deriveLoggers "HSL" [HSL.DEBUG, HSL.ERROR])
|
$(deriveLoggers "HSL" [HSL.DEBUG, HSL.ERROR])
|
||||||
|
|
|
@ -53,4 +53,4 @@ help FullMessage { .. } = case fromMessage message of
|
||||||
let mHelp = find ((\c -> c == command || c == cons '!' command) . fst)
|
let mHelp = find ((\c -> c == command || c == cons '!' command) . fst)
|
||||||
. concatMap mapToList . mapValues $ msgHandlerInfo
|
. concatMap mapToList . mapValues $ msgHandlerInfo
|
||||||
return [toCommand . ChannelMsgReply $ maybe ("No such command found: " ++ command) snd mHelp]
|
return [toCommand . ChannelMsgReply $ maybe ("No such command found: " ++ command) snd mHelp]
|
||||||
_ -> return []
|
_ -> return []
|
||||||
|
|
|
@ -0,0 +1,67 @@
|
||||||
|
{-# 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
|
|
@ -0,0 +1,57 @@
|
||||||
|
{-# 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
|
|
@ -0,0 +1,123 @@
|
||||||
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||||||
|
{-# LANGUAGE ExistentialQuantification #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
|
||||||
|
module Network.IRC.Internal.Message.Types where
|
||||||
|
|
||||||
|
import ClassyPrelude
|
||||||
|
import Data.Data (Data)
|
||||||
|
import Data.SafeCopy (base, deriveSafeCopy)
|
||||||
|
import Data.Typeable (cast)
|
||||||
|
|
||||||
|
-- ** IRC Message
|
||||||
|
|
||||||
|
-- | 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 FullMessage = FullMessage
|
||||||
|
{ msgTime :: !UTCTime -- ^ The time when the message was received.
|
||||||
|
, msgLine :: !Text -- ^ The raw message line.
|
||||||
|
, message :: Message -- ^ 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
|
||||||
|
|
||||||
|
fromMessage :: Message -> Maybe msg
|
||||||
|
fromMessage (Message msg) = cast msg
|
||||||
|
|
||||||
|
-- | A wrapper over all types of IRC messages.
|
||||||
|
data Message = forall m . MessageC m => Message m deriving (Typeable)
|
||||||
|
|
||||||
|
instance Show Message where
|
||||||
|
show (Message m) = show m
|
||||||
|
|
||||||
|
instance Eq Message where
|
||||||
|
Message m1 == Message m2 = case cast m1 of
|
||||||
|
Just m1' -> m1' == m2
|
||||||
|
_ -> False
|
||||||
|
|
||||||
|
-- | The internal (non-IRC) message received when the bot is idle.
|
||||||
|
data IdleMsg = IdleMsg deriving (Typeable, Show, Eq, Ord)
|
||||||
|
instance MessageC IdleMsg
|
||||||
|
|
||||||
|
-- | The message received when the bot's current nick is already in use.
|
||||||
|
data NickInUseMsg = NickInUseMsg deriving (Typeable, Show, Eq, Ord)
|
||||||
|
instance MessageC NickInUseMsg
|
||||||
|
|
||||||
|
-- | A /PING/ message. Must be replied with a 'PongCmd'.
|
||||||
|
data PingMsg = PingMsg !Text deriving (Typeable, Show, Eq, Ord)
|
||||||
|
instance MessageC PingMsg
|
||||||
|
|
||||||
|
-- | A /PONG/ message. Received in response to a 'PingCmd'.
|
||||||
|
data PongMsg = PongMsg !Text deriving (Typeable, Show, Eq, Ord)
|
||||||
|
instance MessageC PongMsg
|
||||||
|
|
||||||
|
-- | A /NAMES/ message which contains a list of nicks of all users in the channel.
|
||||||
|
data NamesMsg = NamesMsg ![Nick] deriving (Typeable, Show, Eq, Ord)
|
||||||
|
instance MessageC NamesMsg
|
||||||
|
|
||||||
|
-- | A /PRIVMSG/ message sent to the channel from a user.
|
||||||
|
data ChannelMsg = ChannelMsg !User !Text deriving (Typeable, Show, Eq, Ord)
|
||||||
|
instance MessageC ChannelMsg
|
||||||
|
|
||||||
|
-- | A /PRIVMSG/ private message sent to the bot from a user.
|
||||||
|
data PrivMsg = PrivMsg !User !Text deriving (Typeable, Show, Eq, Ord)
|
||||||
|
instance MessageC PrivMsg
|
||||||
|
|
||||||
|
-- | An /PRIVMSG/ action message sent to the channel from a user.
|
||||||
|
data ActionMsg = ActionMsg !User !Text deriving (Typeable, Show, Eq, Ord)
|
||||||
|
instance MessageC ActionMsg
|
||||||
|
|
||||||
|
-- | A /JOIN/ message received when a user joins the channel.
|
||||||
|
data JoinMsg = JoinMsg !User deriving (Typeable, Show, Eq, Ord)
|
||||||
|
instance MessageC JoinMsg
|
||||||
|
|
||||||
|
-- | A /QUIT/ message received when a user quits the server.
|
||||||
|
data QuitMsg = QuitMsg !User !Text deriving (Typeable, Show, Eq, Ord)
|
||||||
|
instance MessageC QuitMsg
|
||||||
|
|
||||||
|
-- | A /PART/ message received when a user leaves the channel.
|
||||||
|
data PartMsg = PartMsg !User !Text deriving (Typeable, Show, Eq, Ord)
|
||||||
|
instance MessageC PartMsg
|
||||||
|
|
||||||
|
-- | A /NICK/ message received when a user changes their nick.
|
||||||
|
data NickMsg = NickMsg !User !Nick deriving (Typeable, Show, Eq, Ord)
|
||||||
|
instance MessageC NickMsg
|
||||||
|
|
||||||
|
-- | A /KICK/ message received when a user kicks another user from the channel.
|
||||||
|
data KickMsg = KickMsg { kickUser :: !User, kickedNick :: !Nick, kickMsg :: !Text }
|
||||||
|
deriving (Typeable, Show, Eq, Ord)
|
||||||
|
instance MessageC KickMsg
|
||||||
|
|
||||||
|
-- | A /MODE/ message received when a user's mode changes.
|
||||||
|
data ModeMsg = ModeMsg { modeUser :: !User, modeTarget :: !Text, mode :: !Text , modeArgs :: ![Text] }
|
||||||
|
deriving (Typeable, Show, Eq, Ord)
|
||||||
|
instance MessageC ModeMsg
|
||||||
|
|
||||||
|
-- | All other messages which are not parsed as any of the above types.
|
||||||
|
data OtherMsg = OtherMsg { msgSource :: !Text, msgCommand :: !Text, msgTarget :: !Text , msg :: !Text }
|
||||||
|
deriving (Typeable, Show, Eq, Ord)
|
||||||
|
instance MessageC OtherMsg
|
|
@ -1,186 +1,24 @@
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
|
||||||
{-# LANGUAGE ExistentialQuantification #-}
|
{-# LANGUAGE ExistentialQuantification #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
|
|
||||||
module Network.IRC.Internal.Types where
|
module Network.IRC.Internal.Types where
|
||||||
|
|
||||||
|
import qualified Data.Configurator as CF
|
||||||
|
|
||||||
import ClassyPrelude
|
import ClassyPrelude
|
||||||
import Control.Concurrent.Lifted (Chan)
|
import Control.Concurrent.Lifted (Chan)
|
||||||
import Control.Monad.Base (MonadBase)
|
import Control.Monad.Base (MonadBase)
|
||||||
import Control.Monad.Reader (ReaderT, MonadReader, runReaderT)
|
import Control.Monad.Reader (ReaderT, MonadReader, runReaderT)
|
||||||
import Control.Monad.State (StateT, MonadState, execStateT)
|
import Control.Monad.State (StateT, MonadState, execStateT)
|
||||||
import Data.Configurator.Types (Config)
|
import Data.Configurator.Types (Config)
|
||||||
import Data.Data (Data)
|
|
||||||
import Data.SafeCopy (base, deriveSafeCopy)
|
|
||||||
import Data.Typeable (cast)
|
|
||||||
|
|
||||||
|
import Network.IRC.Internal.Command.Types
|
||||||
|
import Network.IRC.Internal.Event.Types
|
||||||
|
import Network.IRC.Internal.Message.Types
|
||||||
import Network.IRC.Util
|
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 FullMessage = FullMessage
|
|
||||||
{ msgTime :: !UTCTime -- ^ The time when the message was received.
|
|
||||||
, msgLine :: !Text -- ^ The raw message line.
|
|
||||||
, message :: Message -- ^ 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
|
|
||||||
|
|
||||||
fromMessage :: Message -> Maybe msg
|
|
||||||
fromMessage (Message msg) = cast msg
|
|
||||||
|
|
||||||
-- | A wrapper over all types of IRC messages.
|
|
||||||
data Message = forall m . MessageC m => Message m deriving (Typeable)
|
|
||||||
instance Show Message where
|
|
||||||
show (Message m) = show m
|
|
||||||
instance Eq Message where
|
|
||||||
Message m1 == Message m2 = case cast m1 of
|
|
||||||
Just m1' -> m1' == m2
|
|
||||||
_ -> False
|
|
||||||
|
|
||||||
-- | The internal (non-IRC) message received when the bot is idle.
|
|
||||||
data IdleMsg = IdleMsg deriving (Typeable, Show, Eq, Ord)
|
|
||||||
instance MessageC IdleMsg
|
|
||||||
|
|
||||||
-- | The message received when the bot's current nick is already in use.
|
|
||||||
data NickInUseMsg = NickInUseMsg deriving (Typeable, Show, Eq, Ord)
|
|
||||||
instance MessageC NickInUseMsg
|
|
||||||
|
|
||||||
-- | A /PING/ message. Must be replied with a 'PongCmd'.
|
|
||||||
data PingMsg = PingMsg !Text deriving (Typeable, Show, Eq, Ord)
|
|
||||||
instance MessageC PingMsg
|
|
||||||
|
|
||||||
-- | A /PONG/ message. Received in response to a 'PingCmd'.
|
|
||||||
data PongMsg = PongMsg !Text deriving (Typeable, Show, Eq, Ord)
|
|
||||||
instance MessageC PongMsg
|
|
||||||
|
|
||||||
-- | A /NAMES/ message which contains a list of nicks of all users in the channel.
|
|
||||||
data NamesMsg = NamesMsg ![Nick] deriving (Typeable, Show, Eq, Ord)
|
|
||||||
instance MessageC NamesMsg
|
|
||||||
|
|
||||||
-- | A /PRIVMSG/ message sent to the channel from a user.
|
|
||||||
data ChannelMsg = ChannelMsg !User !Text deriving (Typeable, Show, Eq, Ord)
|
|
||||||
instance MessageC ChannelMsg
|
|
||||||
|
|
||||||
-- | A /PRIVMSG/ private message sent to the bot from a user.
|
|
||||||
data PrivMsg = PrivMsg !User !Text deriving (Typeable, Show, Eq, Ord)
|
|
||||||
instance MessageC PrivMsg
|
|
||||||
|
|
||||||
-- | An /PRIVMSG/ action message sent to the channel from a user.
|
|
||||||
data ActionMsg = ActionMsg !User !Text deriving (Typeable, Show, Eq, Ord)
|
|
||||||
instance MessageC ActionMsg
|
|
||||||
|
|
||||||
-- | A /JOIN/ message received when a user joins the channel.
|
|
||||||
data JoinMsg = JoinMsg !User deriving (Typeable, Show, Eq, Ord)
|
|
||||||
instance MessageC JoinMsg
|
|
||||||
|
|
||||||
-- | A /QUIT/ message received when a user quits the server.
|
|
||||||
data QuitMsg = QuitMsg !User !Text deriving (Typeable, Show, Eq, Ord)
|
|
||||||
instance MessageC QuitMsg
|
|
||||||
|
|
||||||
-- | A /PART/ message received when a user leaves the channel.
|
|
||||||
data PartMsg = PartMsg !User !Text deriving (Typeable, Show, Eq, Ord)
|
|
||||||
instance MessageC PartMsg
|
|
||||||
|
|
||||||
-- | A /NICK/ message received when a user changes their nick.
|
|
||||||
data NickMsg = NickMsg !User !Nick deriving (Typeable, Show, Eq, Ord)
|
|
||||||
instance MessageC NickMsg
|
|
||||||
|
|
||||||
-- | A /KICK/ message received when a user kicks another user from the channel.
|
|
||||||
data KickMsg = KickMsg { kickUser :: !User, kickedNick :: !Nick, kickMsg :: !Text }
|
|
||||||
deriving (Typeable, Show, Eq, Ord)
|
|
||||||
instance MessageC KickMsg
|
|
||||||
|
|
||||||
-- | A /MODE/ message received when a user's mode changes.
|
|
||||||
data ModeMsg = ModeMsg { modeUser :: !User, modeTarget :: !Text, mode :: !Text , modeArgs :: ![Text] }
|
|
||||||
deriving (Typeable, Show, Eq, Ord)
|
|
||||||
instance MessageC ModeMsg
|
|
||||||
|
|
||||||
-- | All other messages which are not parsed as any of the above types.
|
|
||||||
data OtherMsg = OtherMsg { msgSource :: !Text, msgCommand :: !Text, msgTarget :: !Text , msg :: !Text }
|
|
||||||
deriving (Typeable, Show, Eq, Ord)
|
|
||||||
instance MessageC OtherMsg
|
|
||||||
|
|
||||||
-- | 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
|
|
||||||
|
|
||||||
-- ** Message Parsing
|
-- ** Message Parsing
|
||||||
|
|
||||||
-- | Message parser id. Should be unique.
|
-- | Message parser id. Should be unique.
|
||||||
|
@ -190,8 +28,8 @@ type MessageParserId = Text
|
||||||
data MessagePart = MessagePart { msgPartParserId :: !MessageParserId
|
data MessagePart = MessagePart { msgPartParserId :: !MessageParserId
|
||||||
, msgPartTarget :: !Text
|
, msgPartTarget :: !Text
|
||||||
, msgPartTime :: !UTCTime
|
, msgPartTime :: !UTCTime
|
||||||
, msgPartLine :: !Text }
|
, msgPartLine :: !Text
|
||||||
deriving (Eq, Show)
|
} deriving (Eq, Show)
|
||||||
|
|
||||||
-- | The result of parsing a message line.
|
-- | The result of parsing a message line.
|
||||||
data MessageParseResult =
|
data MessageParseResult =
|
||||||
|
@ -211,48 +49,6 @@ data MessageParser = MessageParser
|
||||||
-- | A command formatter which optinally formats commands to texts which are then send to the server.
|
-- | 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 -> Command -> Maybe Text
|
||||||
|
|
||||||
-- ** 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
|
|
||||||
|
|
||||||
-- ** Bot
|
-- ** Bot
|
||||||
|
|
||||||
-- | Name of a message handler.
|
-- | Name of a message handler.
|
||||||
|
@ -286,24 +82,22 @@ data BotConfig = BotConfig
|
||||||
}
|
}
|
||||||
|
|
||||||
instance Show BotConfig where
|
instance Show BotConfig where
|
||||||
show BotConfig { .. } = "server = " ++ show server ++ "\n" ++
|
show BotConfig { .. } = "BotConfig[ server = " ++ show server ++ "\n" ++
|
||||||
"port = " ++ show port ++ "\n" ++
|
"port = " ++ show port ++ "\n" ++
|
||||||
"channel = " ++ show channel ++ "\n" ++
|
"channel = " ++ show channel ++ "\n" ++
|
||||||
"nick = " ++ show botNick ++ "\n" ++
|
"nick = " ++ show botNick ++ "\n" ++
|
||||||
"timeout = " ++ show botTimeout ++ "\n" ++
|
"timeout = " ++ show botTimeout ++ "\n" ++
|
||||||
"handlers = " ++ show (mapKeys msgHandlerInfo)
|
"handlers = " ++ show (mapKeys msgHandlerInfo) ++ " ]"
|
||||||
|
|
||||||
-- | Creates a new bot config with some fields as empty.
|
-- | Creates a new bot config with essential fields leaving rest fields empty.
|
||||||
newBotConfig :: Text -- ^ server
|
newBotConfig :: Text -- ^ server
|
||||||
-> Int -- ^ port
|
-> Int -- ^ port
|
||||||
-> Text -- ^ channel
|
-> Text -- ^ channel
|
||||||
-> Nick -- ^ botNick
|
-> Nick -- ^ botNick
|
||||||
-> Int -- ^ botTimeout
|
-> Int -- ^ botTimeout
|
||||||
-> Map MsgHandlerName (Map Text Text) -- ^ msgHandlerInfo
|
|
||||||
-> Config -- ^ config
|
|
||||||
-> BotConfig
|
-> BotConfig
|
||||||
newBotConfig server port channel botNick botTimeout msgHandlerInfo =
|
newBotConfig server port channel botNick botTimeout =
|
||||||
BotConfig server port channel botNick botTimeout msgHandlerInfo [] [] []
|
BotConfig server port channel botNick botTimeout mempty [] [] [] CF.empty
|
||||||
|
|
||||||
-- | The bot.
|
-- | The bot.
|
||||||
data Bot = Bot
|
data Bot = Bot
|
||||||
|
|
|
@ -12,8 +12,8 @@ import Network.IRC.Types
|
||||||
|
|
||||||
parseLine :: BotConfig -> UTCTime -> Text -> [MessagePart] -> (Maybe FullMessage, [MessagePart])
|
parseLine :: BotConfig -> UTCTime -> Text -> [MessagePart] -> (Maybe FullMessage, [MessagePart])
|
||||||
parseLine botConfig@BotConfig { .. } time line msgParts =
|
parseLine botConfig@BotConfig { .. } time line msgParts =
|
||||||
fromMaybe (Nothing, msgParts) . msum . flip map parsers $ \MessageParser { .. } -> let
|
fromMaybe (Nothing, msgParts) . msum . flip map parsers $ \MessageParser { .. } ->
|
||||||
(parserMsgParts, otherParserMsgParts) = partition ((msgParserId ==) . msgPartParserId) msgParts
|
let (parserMsgParts, otherParserMsgParts) = partition ((msgParserId ==) . msgPartParserId) msgParts
|
||||||
in case msgParser botConfig time line parserMsgParts of
|
in case msgParser botConfig time line parserMsgParts of
|
||||||
Reject -> Nothing
|
Reject -> Nothing
|
||||||
Partial msgParts' -> Just (Nothing, msgParts' ++ otherParserMsgParts)
|
Partial msgParts' -> Just (Nothing, msgParts' ++ otherParserMsgParts)
|
||||||
|
@ -31,11 +31,11 @@ pingParser = MessageParser "ping" go
|
||||||
parseMsgLine :: Text -> ([Text], Text, Text, Text, Text)
|
parseMsgLine :: Text -> ([Text], Text, Text, Text, Text)
|
||||||
parseMsgLine line = (splits, command, source, target, message)
|
parseMsgLine line = (splits, command, source, target, message)
|
||||||
where
|
where
|
||||||
splits = words line
|
splits = words line
|
||||||
command = splits !! 1
|
command = splits !! 1
|
||||||
source = drop 1 $ splits !! 0
|
source = drop 1 $ splits !! 0
|
||||||
target = splits !! 2
|
target = splits !! 2
|
||||||
message = strip . drop 1 . unwords . drop 3 $ splits
|
message = strip . drop 1 . unwords . drop 3 $ splits
|
||||||
|
|
||||||
lineParser :: MessageParser
|
lineParser :: MessageParser
|
||||||
lineParser = MessageParser "line" go
|
lineParser = MessageParser "line" go
|
||||||
|
@ -111,6 +111,6 @@ defaultCommandFormatter BotConfig { .. } command
|
||||||
| Just (PrivMsgReply (User { .. }) msg) <- fromCommand command =
|
| Just (PrivMsgReply (User { .. }) msg) <- fromCommand command =
|
||||||
Just $ "PRIVMSG " ++ nickToText userNick ++ " :" ++ msg
|
Just $ "PRIVMSG " ++ nickToText userNick ++ " :" ++ msg
|
||||||
| Just NamesCmd <- fromCommand command = Just $ "NAMES " ++ channel
|
| Just NamesCmd <- fromCommand command = Just $ "NAMES " ++ channel
|
||||||
| otherwise = Nothing
|
| otherwise = Nothing
|
||||||
where
|
where
|
||||||
botNick' = nickToText botNick
|
botNick' = nickToText botNick
|
||||||
|
|
|
@ -68,4 +68,8 @@ module Network.IRC.Types
|
||||||
, MsgHandlerMaker (..)
|
, MsgHandlerMaker (..)
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import Network.IRC.Internal.Command.Types
|
||||||
|
import Network.IRC.Internal.Event.Types
|
||||||
|
import Network.IRC.Internal.Message.Types
|
||||||
import Network.IRC.Internal.Types
|
import Network.IRC.Internal.Types
|
||||||
|
|
||||||
|
|
|
@ -74,7 +74,10 @@ library
|
||||||
Network.IRC.Client,
|
Network.IRC.Client,
|
||||||
Network.IRC.Util
|
Network.IRC.Util
|
||||||
|
|
||||||
other-modules: Network.IRC.Internal.Types,
|
other-modules: Network.IRC.Internal.Command.Types,
|
||||||
|
Network.IRC.Internal.Event.Types,
|
||||||
|
Network.IRC.Internal.Message.Types,
|
||||||
|
Network.IRC.Internal.Types,
|
||||||
Network.IRC.Protocol,
|
Network.IRC.Protocol,
|
||||||
Network.IRC.Bot,
|
Network.IRC.Bot,
|
||||||
Network.IRC.Handlers.Core
|
Network.IRC.Handlers.Core
|
||||||
|
|
|
@ -16,22 +16,23 @@ instance Configured a => Configured [a] where
|
||||||
|
|
||||||
loadBotConfig :: String -> IO BotConfig
|
loadBotConfig :: String -> IO BotConfig
|
||||||
loadBotConfig configFile = do
|
loadBotConfig configFile = do
|
||||||
eCfg <- try $ CF.load [CF.Required configFile]
|
eConfig <- try $ CF.load [CF.Required configFile]
|
||||||
case eCfg of
|
case eConfig of
|
||||||
Left (ParseError _ _) -> error "Error while loading config"
|
Left (ParseError _ _) -> error "Error while loading config"
|
||||||
Right cfg -> do
|
Right config -> do
|
||||||
eBotConfig <- try $ do
|
eBotConfig <- try $ do
|
||||||
handlers :: [Text] <- CF.require cfg "msghandlers"
|
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
|
||||||
botConfig <- newBotConfig <$>
|
botConfig <- newBotConfig <$>
|
||||||
CF.require cfg "server" <*>
|
CF.require config "server" <*>
|
||||||
CF.require cfg "port" <*>
|
CF.require config "port" <*>
|
||||||
CF.require cfg "channel" <*>
|
CF.require config "channel" <*>
|
||||||
(Nick <$> CF.require cfg "nick") <*>
|
(Nick <$> CF.require config "nick") <*>
|
||||||
CF.require cfg "timeout" <*>
|
CF.require config "timeout"
|
||||||
pure handlerInfo <*>
|
return botConfig { msgHandlerInfo = handlerInfo
|
||||||
pure cfg
|
, msgHandlerMakers = allMsgHandlerMakers
|
||||||
return botConfig { msgHandlerMakers = allMsgHandlerMakers }
|
, config = config
|
||||||
|
}
|
||||||
|
|
||||||
case eBotConfig of
|
case eBotConfig of
|
||||||
Left (KeyError k) -> error $ "Error while reading key from config: " ++ unpack k
|
Left (KeyError k) -> error $ "Error while reading key from config: " ++ unpack k
|
||||||
|
|
Loading…
Reference in New Issue