Events.hs

{- This file is part of irc-fun-client.
 -
 - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

{-# LANGUAGE OverloadedStrings #-}

-- | This module allows you to identify IRC events. Events are a wrapper around
-- IRC messages, which provide a logical layer convenient to work with (while
-- IRC messages have their lower level aspects, being plain protocol messages).
module Network.IRC.Fun.Client.Events
    ( Event (..)
    , detectEvents
    , hGetIrcEventsOnce
    , hGetIrcEvents
    )
where

import Control.Monad (unless)
import Data.Maybe (fromMaybe, isNothing)
import Data.Text (Text)
import Network.IRC.Fun.Client.IO (Connection, Result (..), hGetIrcOnce)
import Network.IRC.Fun.Messages
import Network.IRC.Fun.Types

-- | An event triggered by an IRC message sent from the server.
data Event
    -- | A ping was sent to the bot. The parameters are the server name and
    -- optionally a server to forward the response to. They can be passed as-is
    -- directly to the PONG response.
    = Ping Hostname (Maybe Hostname)
    -- | A ping response sent by the server.
    | Pong Hostname (Maybe Hostname)
    -- | One or more users have been kicked from a channel for an optionally
    -- given reason. Parameters: Channel, nicknames, reason.
    | Kick Channel [Nickname] (Maybe Comment)
    -- | A user joined a channel. Parameters: Channel, nickname.
    | Join Channel Nickname
    -- | A user left a channel, optionally with a given reason. Parameters:
    -- Channel, nickname, reason.
    | Part Channel Nickname (Maybe Comment)
    -- | A user left the network, optonally for the given reason. Parameters:
    -- Nickname, reason.
    | Quit Nickname (Maybe Comment)
    -- | TODO
    | Mode
    -- | Message sent in a channel by a user. The last parameter indicates
    -- whether the message is actually a notice. If yes, the client shouldn't
    -- automatically send a response. Parameters: Channel, nickname, message,
    -- whether notice.
    | ChannelMessage Channel Nickname MsgContent Bool
    -- | A channel message that is a virtual action (/me).
    | ChannelAction Channel Nickname MsgContent
    -- | A private message sent specifically to the client from a user. The
    -- last parameter indicates whether the message is actually a notice. If
    -- yes, the client shouldn't send any automatic response. Parameters:
    -- Nickname, message, whether notice.
    | PrivateMessage Nickname MsgContent Bool
    -- | A private message that is a virtual action (/me).
    | PrivateAction Nickname MsgContent
    -- | A user's nickname has changed. Parameters: Old nick, new nick.
    | NickChange Nickname Nickname
    -- | Channel topic change. Parameterss: Channel, nickname of user who
    -- changed the topic, new topic content.
    | Topic Channel Nickname ChannelTopic
    -- | The client has been invited to a channel by another user. Parameters:
    -- Channel, nickname of inviting user.
    | Invite Channel Nickname
    -- | The server sent a list of nicknames present in a channel. Parameters:
    -- Channel privacy mode, channel name, list of users. Each list item is a
    -- pair of a user privilege level in the channel, and the user's nickname.
    | Names ChannelPrivacy Channel [(Privilege, Nickname)]
    -- | Unused, unrecognized or unimplemented event. A successfuly analyzed
    -- IRC message not (yet) recognized by this library as any of the client
    -- events above. Error message provided too. This event can be a result of
    -- an error or bug, missing features in this library or simply an IRC
    -- message that isn't interesting to an IRC client. Or perhaps the IRC
    -- server sent an invalid/empty message.
    | OtherSpecific (Either SpecificReply SpecificMessage) Text
    -- | Unrecognized or unimplemented event. An IRC protocol message not known
    -- to the message analyzer or whose analysis has failed. Error message
    -- provided too.
    | OtherGeneric GenericMessage Text
    -- | An IRC protocol message whose parsing has failed.
    | OtherRaw Text
    -- | Some other unrecognized event. The parameter contains possibly empty
    -- input.
    | OtherEvent Text
    deriving Show

detectMessageEvents :: SpecificMessage -> [Event]
detectMessageEvents sm@(SpecificMessage mpref msg) =
    case msg of
        NickMessage newnick -> withSender $ \ sender ->
            one $ NickChange sender newnick
        QuitMessage reason -> withSender $ \ sender ->
            one $ Quit sender reason
        JoinMessage (Just ([chan], [])) -> withSender $ \ sender ->
            one $ Join chan sender
        JoinMessage _ -> other "Expected JOIN with a single channel and no key"
        PartMessage [chan] reason -> withSender $ \ sender ->
            one $ Part chan sender reason
        PartMessage _ _ -> other "Expected PART with a single channel"
        TopicMessage _ Nothing -> other "Expected a topic in TOPIC"
        TopicMessage chan (Just topic) -> withSender $ \ sender ->
            one $ Topic chan sender topic
        PingMessage s ms ->
            one $ Ping s ms
        PongMessage s ms ->
            one $ Pong s ms
        KickMessage [] _ _ -> other "Empty channel list"
        KickMessage _ [] _ -> other "Empty nickname list"
        KickMessage [chan] nicks comment ->
            one $ Kick chan (map u2n nicks) comment
        KickMessage chans nicks comment ->
            if length chans == length nicks
                then map (\ (c, n) -> Kick c [u2n n] comment) $ zip chans nicks
                else other "Channel and nickname lists not in same length"
        PrivMsgMessage (ChannelTarget chan) mc -> withSender $ \ sender ->
            one $ ChannelMessage chan sender mc False
        PrivMsgMessage (UserTarget _ _ _) mc -> withSender $ \ sender ->
            one $ PrivateMessage sender mc False
        PrivMsgMessage (MaskTarget _) _ -> other "Expected user/channel target"
        PrivActionMessage (ChannelTarget chan) mc -> withSender $ \ sender ->
            one $ ChannelAction chan sender mc
        PrivActionMessage (UserTarget _ _ _) mc -> withSender $ \ sender ->
            one $ PrivateAction sender mc
        PrivActionMessage (MaskTarget _) _ -> other "Expected user/chan target"
        _ -> other "Currently not recognized as a client event"
    where
    one e = [e]
    other = one . OtherSpecific (Right sm)
    withSender f =
        case mpref of
            Just (PrefixNick n _ _) -> f n
            Just (PrefixServer _) ->
                other "Expected nickname in prefix, but found server"
            Nothing ->
                other "Expected nickname in prefix, but no prefix found"
    u2n (Username u) = Nickname u

detectReplyEvents :: SpecificReply -> [Event]
detectReplyEvents sr@(SpecificReply _sender _target rpl) =
    case rpl of
        NamesReply priv chan pnicks -> one $ Names priv chan pnicks
        _ -> other "Currently not recognized as a client event"
    where
    one e = [e]
    other = one . OtherSpecific (Left sr)

-- | Try to generate events from an IRC message.
detectEvents :: Either SpecificReply SpecificMessage -> [Event]
detectEvents = either detectReplyEvents detectMessageEvents

-- | Receive IRC events. If parsing the message fails, one of the @Other*@
-- events is returned according to the error.
hGetIrcEventsOnce :: Connection -> IO [Event]
hGetIrcEventsOnce c = do
    res <- hGetIrcOnce c
    return $ case res of
        ParsingFailed t       -> [OtherRaw t]
        AnalysisFailed gm err -> [OtherGeneric gm err]
        GotReply sr           -> detectReplyEvents sr
        GotMessage sm         -> detectMessageEvents sm

-- | Receive the next valid (successfully parsed and detected) series of IRC
-- events, in the second element. The first element is failure events (i.e. one
-- of the @Other*@ constructors) received before that, if there were any.
hGetIrcEvents :: Connection -> IO ([Event], [Event])
hGetIrcEvents c = do
    (l, m) <- f []
    return (reverse l, m)
    where
    f errs = do
        res <- hGetIrcEventsOnce c
        case res of
            [o@OtherSpecific {}] -> f $ o : errs
            [o@OtherGeneric {}]  -> f $ o : errs
            [o@OtherRaw {}]      -> f $ o : errs
            [o@OtherEvent {}]    -> f $ o : errs
            _                    -> return (errs, res)