hask-irc/hask-irc-core/Network/IRC/Internal/Types.hs

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}

module Network.IRC.Internal.Types 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 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 parser id. Should be unique.
type MessageParserId = Text

-- | A part of a mutlipart message.
data MessagePart = MessagePart { msgPartParserId   :: !MessageParserId
                               , msgPartTarget     :: !Text
                               , msgPartTime       :: !UTCTime
                               , msgPartLine       :: !Text }
                   deriving (Eq, Show)

-- | The result of parsing a message line.
data MessageParseResult =
    Done !FullMessage ![MessagePart] -- ^ A fully parsed message and leftover message parts.
  | Partial ![MessagePart]           -- ^ A partial message with message parts received yet.
  | Reject                           -- ^ Returned if a message line cannot be parsed by a particular parser.
  deriving (Eq, Show)

-- | A message parser used for parsing text lines from the server to 'Message's.
data MessageParser = MessageParser
  { msgParserId :: !MessageParserId
  , msgParser   :: !(BotConfig -> UTCTime -> Text -> [MessagePart] -> MessageParseResult)
  }

-- ** Command Formatting

-- | A command formatter which optinally formats commands to texts which are then send to the server.
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

-- | 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]
  -- | A list of extra message parsers. Note that these parsers will always be called after the built-in ones.
  , msgParsers       :: ![MessageParser]
  -- | A list of extra command formatters. Note that these formatters will always be called after the built-in ones.
  , cmdFormatters    :: ![CommandFormatter]
  -- | 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)

-- | Creates a new bot config with some fields as empty.
newBotConfig :: Text                               -- ^ server
             -> Int                                -- ^ port
             -> Text                               -- ^ channel
             -> Nick                               -- ^ botNick
             -> Int                                -- ^ botTimeout
             -> Map MsgHandlerName (Map Text Text) -- ^ msgHandlerInfo
             -> Config                             -- ^ config
             -> BotConfig
newBotConfig server port channel botNick botTimeout msgHandlerInfo =
  BotConfig server port channel botNick botTimeout 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
  fromMsgHandler :: MsgHandlerT a -> m a

instance MonadMsgHandler MsgHandlerT where
  fromMsgHandler = 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 => FullMessage -> m [Command])
  -- | The action invoked when an event is triggered. It returns an event resonpse which the bot
  -- handles according to its type.
  , onEvent   :: !(forall m . MonadMsgHandler m => Event -> m EventResponse)
  -- | 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 Event -> 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.
              -> FullMessage   -- ^ 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.
            -> Event             -- ^ The event to handle.
            -> IO EventResponse  -- ^ The event response which will be dispatched by the bot.
handleEvent MsgHandler { .. } botConfig =
  flip runReaderT botConfig . _runMsgHandler . onEvent

-- | Stops a message handler.
stopMsgHandler :: MsgHandler    -- ^ The message handler.
               -> BotConfig     -- ^ The bot config.
               -> 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