Messages.hs

{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module:     Network.FastIRC.Messages
-- Copyright:  (c) 2010 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
-- Stability:  alpha
--
-- Parser and printer for IRC messages.

module Network.FastIRC.Messages
  ( -- * IRC messages
    Message(..),
    messageParser,
    readMessage,
    showMessage,

    -- * IRC commands
    Command(..),
    commandParser,
    showCommand
  )
  where

import qualified Data.ByteString.Char8 as B
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Applicative
import Control.Monad
import Data.Attoparsec.Char8 as P hiding (many)
import Data.Char
import Data.Map (Map)
import Data.Maybe
import Data.Set (Set)
import Network.FastIRC.Types
import Network.FastIRC.Users
import Network.FastIRC.Utils
import Text.Printf


-- | Data type for IRC messages.

data Message =
  Message {
    msgOrigin  :: !(Maybe UserSpec), -- ^ Message origin (user/server).
    msgCommand :: !Command           -- ^ Message command or numeric.
  }
  deriving (Eq, Read, Show)


-- | Data type for IRC commands.

data Command
  = StringCmd CommandName [CommandArg]  -- ^ Arbitrary string command.
  | NumericCmd Integer [CommandArg]     -- ^ Arbitrary numeric command.

  | JoinCmd     (Map ChannelName (Maybe ChannelKey))
  | KickCmd     (Set ChannelName) (Set NickName) (Maybe CommandArg)
  | ModeCmd     (Maybe (TargetName, CommandArg, [CommandArg]))
  | NickCmd     NickName (Maybe Int)
  | NoticeCmd   (Set TargetName) CommandArg
  | PartCmd     (Set ChannelName) (Maybe CommandArg)
  | PassCmd     CommandArg
  | PingCmd     ServerName (Maybe ServerName)
  | PongCmd     ServerName (Maybe ServerName)
  | PrivMsgCmd  (Set TargetName) CommandArg
  | QuitCmd     (Maybe CommandArg)
  | TopicCmd    ChannelName (Maybe CommandArg)
  | UserCmd     UserName CommandArg CommandArg CommandArg

  deriving (Eq, Read, Show)


-- | Parser for IRC commands and their arguments.

commandParser :: Parser Command
commandParser =
  try numCmd <|>
  stringCmd

  where
    cmdArg :: Parser CommandArg
    cmdArg = do
      skipMany1 (char ' ')
      try lastArg <|> takeWhile1 isIRCTokChar

      where
        lastArg :: Parser CommandArg
        lastArg = char ':' *> P.takeWhile isMessageChar

    commaArg :: Parser (Set CommandArg)
    commaArg = S.filter (not . B.null) . S.fromList . B.split ',' <$> cmdArg

    intArg :: Parser (Maybe Int)
    intArg = option Nothing (fmap fst . B.readInt <$> cmdArg)

    joinCmd :: Parser Command
    joinCmd = do
      channels <- B.split ',' <$> cmdArg
      keys <- option [] $ B.split ',' <$> cmdArg
      many cmdArg
      return . JoinCmd . M.fromList $
        zip channels (map Just keys ++ repeat Nothing)

    numCmd :: Parser Command
    numCmd = NumericCmd <$> decimal <*> many cmdArg

    optArg :: Parser (Maybe CommandArg)
    optArg = option Nothing (Just <$> cmdArg)

    stringCmd :: Parser Command
    stringCmd = do
      cmd <- B.map toUpper <$> takeWhile1 isCommandChar
      case cmd of
        "JOIN" -> joinCmd
        "KICK" -> KickCmd <$> commaArg <*> commaArg <*> optArg <* many cmdArg
        "MODE" ->
          try ((\a b c -> ModeCmd (Just (a,b,c)))
               <$> cmdArg
               <*> cmdArg
               <*> many cmdArg)
          <|> (many cmdArg >>= guard . null >> pure (ModeCmd Nothing))
        "NICK" -> NickCmd <$> cmdArg <*> intArg <* many cmdArg
        "NOTICE" -> NoticeCmd <$> commaArg <*> cmdArg <* many cmdArg
        "PART" -> PartCmd <$> commaArg <*> optArg <* many cmdArg
        "PASS" -> PassCmd <$> cmdArg <* many cmdArg
        "PING" -> PingCmd <$> cmdArg <*> optArg <* many cmdArg
        "PONG" -> PongCmd <$> cmdArg <*> optArg <* many cmdArg
        "PRIVMSG" -> PrivMsgCmd <$> commaArg <*> cmdArg <* many cmdArg
        "QUIT" -> QuitCmd <$> optArg <* many cmdArg
        "TOPIC" -> TopicCmd <$> cmdArg <*> optArg <* many cmdArg
        "USER" -> UserCmd <$> cmdArg <*> cmdArg <*> cmdArg <*> cmdArg <* many cmdArg
        _      -> StringCmd cmd <$> many cmdArg


-- | Parser for IRC messages.

messageParser :: Parser Message
messageParser =
  Message <$> option Nothing (Just <$> try userSpec)
          <*> commandParser

  where
    userSpec :: Parser UserSpec
    userSpec = char ':' *> userParser <* skipMany1 (char ' ')


-- | Run the 'messageParser' parser.

readMessage :: MsgString -> Maybe Message
readMessage = parseComplete messageParser


-- | Turn a 'Command' into a 'B.ByteString'.  If you need to specify an
-- origin for the command, you should use 'Message' together with
-- 'showMessage'.

showCommand :: Command -> MsgString
showCommand cmd =
  case cmd of
    StringCmd cmdStr args  -> B.append cmdStr (showArgs args)
    NumericCmd cmdNum args ->
      B.append (B.pack . printf "%03i" $ cmdNum)
               (showArgs args)

    JoinCmd channels ->
      case formatJoins channels of
        (chanList, "")      -> "JOIN" +-+ [chanList]
        (chanList, keyList) -> "JOIN" +-+ [chanList, keyList]
    KickCmd channels nicks Nothing ->
      "KICK" +-+ [commaList channels, commaList nicks]
    KickCmd channels nicks (Just reason) ->
      "KICK" +-+ [commaList channels, commaList nicks, reason]
    ModeCmd Nothing          -> "MODE"
    ModeCmd (Just (target, mode, args)) ->
      "MODE" +-+ [target, mode] ++ args
    NickCmd nick (Just hc)   -> "NICK" +-+ [nick, B.pack (show hc)]
    NickCmd nick Nothing     -> "NICK" +-+ [nick]
    NoticeCmd targets text   -> "NOTICE" +-+ [commaList targets, text]
    PartCmd chans Nothing    -> "PART" +-+ [commaList chans]
    PartCmd chans (Just reason) ->
      "PART" +-+ [commaList chans, reason]
    PassCmd pwd              -> "PASS" +-+ [pwd]
    PingCmd srv1 Nothing     -> "PING" +-+ [srv1]
    PingCmd srv1 (Just srv2) -> "PING" +-+ [srv1, srv2]
    PongCmd srv1 Nothing     -> "PONG" +-+ [srv1]
    PongCmd srv1 (Just srv2) -> "PONG" +-+ [srv1, srv2]
    PrivMsgCmd targets text  -> "PRIVMSG" +-+ [commaList targets, text]
    QuitCmd Nothing          -> "QUIT" +-+ []
    QuitCmd (Just reason)    -> "QUIT" +-+ [reason]
    TopicCmd channel Nothing -> "TOPIC" +-+ [channel]
    TopicCmd channel (Just newTopic) ->
      "TOPIC" +-+ [channel, newTopic]
    UserCmd user vhost vport realName ->
      "USER" +-+ [user, vhost, vport, realName]

  where
    (+-+) :: B.ByteString -> [B.ByteString] -> B.ByteString
    cmd +-+ args = B.append cmd (showArgs args)
    infix 4 +-+

    formatJoins :: Map ChannelName (Maybe ChannelKey) ->
                   (CommandArg, CommandArg)
    formatJoins channels = (chanList, keyList)
      where
        (withKey, withoutKey) = M.partition isJust channels
        chanWithKeyAssocs = M.assocs withKey
        chanList = B.intercalate "," $ map fst chanWithKeyAssocs ++
                                       M.keys withoutKey
        keyList  = B.intercalate "," $ map (fromJust . snd) chanWithKeyAssocs

    commaList :: Set CommandArg -> CommandArg
    commaList = B.intercalate "," . S.toList

    showArgs :: [CommandArg] -> MsgString
    showArgs [] = B.empty
    showArgs [arg]
      | B.null arg        = " :"
      | B.head arg == ':' = B.append " :" arg
      | B.elem ' ' arg    = B.append " :" arg
      | otherwise         = B.cons ' ' arg
    showArgs (arg:args) =
      B.append (B.cons ' ' arg) (showArgs args)


-- | Turn a 'Message' into a 'B.ByteString'.

showMessage :: Message -> MsgString
showMessage (Message origin cmd) =
  case origin of
    Nothing -> showCommand cmd
    Just o  ->
      B.append (':' `B.cons` showUserSpec o)
               (' ' `B.cons` showCommand cmd)