module Irc.Message
(
IrcMsg(..)
, CapCmd(..)
, cookIrcMsg
, MessageTarget(..)
, ircMsgText
, msgTarget
, msgActor
, nickSplit
, computeMaxMessageLength
) where
import Control.Monad
import Data.Function
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Read as Text
import Irc.Identifier
import Irc.RawIrcMsg
import Irc.UserInfo
import Irc.Codes
import View
data IrcMsg
= UnknownMsg !RawIrcMsg
| Reply !ReplyCode [Text]
| Nick !UserInfo !Identifier
| Join !UserInfo !Identifier
| Part !UserInfo !Identifier (Maybe Text)
| Quit !UserInfo (Maybe Text)
| Kick !UserInfo !Identifier !Identifier !Text
| Topic !UserInfo !Identifier !Text
| Privmsg !UserInfo !Identifier !Text
| Ctcp !UserInfo !Identifier !Text !Text
| CtcpNotice !UserInfo !Identifier !Text !Text
| Notice !UserInfo !Identifier !Text
| Mode !UserInfo !Identifier [Text]
| Authenticate !Text
| Cap !CapCmd [Text]
| Ping [Text]
| Pong [Text]
| Error !Text
| BatchStart Text Text [Text]
| BatchEnd Text
deriving Show
data CapCmd
= CapLs
| CapList
| CapReq
| CapAck
| CapNak
| CapEnd
deriving (Show, Eq, Ord)
cookCapCmd :: Text -> Maybe CapCmd
cookCapCmd "LS" = Just CapLs
cookCapCmd "LIST" = Just CapList
cookCapCmd "ACK" = Just CapAck
cookCapCmd "NAK" = Just CapNak
cookCapCmd "END" = Just CapEnd
cookCapCmd "REQ" = Just CapReq
cookCapCmd _ = Nothing
cookIrcMsg :: RawIrcMsg -> IrcMsg
cookIrcMsg msg =
case view msgCommand msg of
cmd | Right (n,"") <- decimal cmd ->
Reply (ReplyCode n) (view msgParams msg)
"CAP" | _target:cmdTxt:rest <- view msgParams msg
, Just cmd <- cookCapCmd cmdTxt ->
Cap cmd rest
"AUTHENTICATE" | x:_ <- view msgParams msg ->
Authenticate x
"PING" -> Ping (view msgParams msg)
"PONG" -> Pong (view msgParams msg)
"PRIVMSG" | Just user <- view msgPrefix msg
, [chan,txt] <- view msgParams msg ->
case parseCtcp txt of
Just (cmd,args) -> Ctcp user (mkId chan) (Text.toUpper cmd) args
Nothing -> Privmsg user (mkId chan) txt
"NOTICE" | Just user <- view msgPrefix msg
, [chan,txt] <- view msgParams msg ->
case parseCtcp txt of
Just (cmd,args) -> CtcpNotice user (mkId chan) (Text.toUpper cmd) args
Nothing -> Notice user (mkId chan) txt
"JOIN" | Just user <- view msgPrefix msg
, chan:_ <- view msgParams msg ->
Join user (mkId chan)
"QUIT" | Just user <- view msgPrefix msg
, reasons <- view msgParams msg ->
Quit user (listToMaybe reasons)
"PART" | Just user <- view msgPrefix msg
, chan:reasons <- view msgParams msg ->
Part user (mkId chan) (listToMaybe reasons)
"NICK" | Just user <- view msgPrefix msg
, newNick:_ <- view msgParams msg ->
Nick user (mkId newNick)
"KICK" | Just user <- view msgPrefix msg
, [chan,nick,reason] <- view msgParams msg ->
Kick user (mkId chan) (mkId nick) reason
"TOPIC" | Just user <- view msgPrefix msg
, [chan,topic] <- view msgParams msg ->
Topic user (mkId chan) topic
"MODE" | Just user <- view msgPrefix msg
, target:modes <- view msgParams msg ->
Mode user (mkId target) modes
"ERROR" | [reason] <- view msgParams msg ->
Error reason
"BATCH" | refid : ty : params <- view msgParams msg
, Just ('+',refid') <- Text.uncons refid ->
BatchStart refid' ty params
"BATCH" | [refid] <- view msgParams msg
, Just ('-',refid') <- Text.uncons refid ->
BatchEnd refid'
_ -> UnknownMsg msg
parseCtcp :: Text -> Maybe (Text, Text)
parseCtcp txt =
do txt1 <- Text.stripSuffix "\^A" =<< Text.stripPrefix "\^A" txt
let (cmd,args) = Text.break (==' ') txt1
guard (not (Text.null cmd))
return (cmd, Text.drop 1 args)
data MessageTarget
= TargetUser !Identifier
| TargetWindow !Identifier
| TargetNetwork
| TargetHidden
msgTarget :: Identifier -> IrcMsg -> MessageTarget
msgTarget me msg =
case msg of
UnknownMsg{} -> TargetNetwork
Nick user _ -> TargetUser (userNick user)
Mode _ tgt _ | tgt == me -> TargetNetwork
| otherwise -> TargetWindow tgt
Join _ chan -> TargetWindow chan
Part _ chan _ -> TargetWindow chan
Quit user _ -> TargetUser (userNick user)
Kick _ chan _ _ -> TargetWindow chan
Topic _ chan _ -> TargetWindow chan
Privmsg src tgt _ | tgt == me -> TargetWindow (userNick src)
| otherwise -> TargetWindow tgt
Ctcp src tgt _ _ | tgt == me -> TargetWindow (userNick src)
| otherwise -> TargetWindow tgt
CtcpNotice src tgt _ _ | tgt == me -> TargetWindow (userNick src)
| otherwise -> TargetWindow tgt
Notice src tgt _ | tgt == me -> TargetWindow (userNick src)
| otherwise -> TargetWindow tgt
Authenticate{} -> TargetHidden
Ping{} -> TargetHidden
Pong{} -> TargetHidden
Error{} -> TargetNetwork
Cap{} -> TargetNetwork
Reply{} -> TargetNetwork
BatchStart{} -> TargetHidden
BatchEnd{} -> TargetHidden
msgActor :: IrcMsg -> Maybe UserInfo
msgActor msg =
case msg of
UnknownMsg{} -> Nothing
Reply{} -> Nothing
Nick x _ -> Just x
Join x _ -> Just x
Part x _ _ -> Just x
Quit x _ -> Just x
Kick x _ _ _ -> Just x
Topic x _ _ -> Just x
Privmsg x _ _ -> Just x
Ctcp x _ _ _ -> Just x
CtcpNotice x _ _ _ -> Just x
Notice x _ _ -> Just x
Mode x _ _ -> Just x
Authenticate{}-> Nothing
Ping{} -> Nothing
Pong{} -> Nothing
Error{} -> Nothing
Cap{} -> Nothing
BatchStart{} -> Nothing
BatchEnd{} -> Nothing
ircMsgText :: IrcMsg -> Text
ircMsgText msg =
case msg of
UnknownMsg raw -> Text.unwords (view msgCommand raw : view msgParams raw)
Reply (ReplyCode n) xs -> Text.unwords (Text.pack (show n) : xs)
Nick x y -> Text.unwords [renderUserInfo x, idText y]
Join x _ -> renderUserInfo x
Part x _ mb -> Text.unwords (renderUserInfo x : maybeToList mb)
Quit x mb -> Text.unwords (renderUserInfo x : maybeToList mb)
Kick x _ z r -> Text.unwords [renderUserInfo x, idText z, r]
Topic x _ t -> Text.unwords [renderUserInfo x, t]
Privmsg x _ t -> Text.unwords [renderUserInfo x, t]
Ctcp x _ c t -> Text.unwords [renderUserInfo x, c, t]
CtcpNotice x _ c t -> Text.unwords [renderUserInfo x, c, t]
Notice x _ t -> Text.unwords [renderUserInfo x, t]
Mode x _ xs -> Text.unwords (renderUserInfo x:"set mode":xs)
Ping xs -> Text.unwords xs
Pong xs -> Text.unwords xs
Cap _ xs -> Text.unwords xs
Error t -> t
Authenticate{} -> ""
BatchStart{} -> ""
BatchEnd{} -> ""
isNickChar :: Char -> Bool
isNickChar x = '0' <= x && x <= '9'
|| 'A' <= x && x <= '}'
|| '-' == x
nickSplit :: Text -> [Text]
nickSplit = Text.groupBy ((==) `on` isNickChar)
computeMaxMessageLength :: UserInfo -> Text -> Int
computeMaxMessageLength myUserInfo target
= 512
Text.length (renderUserInfo myUserInfo)
length (": PRIVMSG :\r\n"::String)
Text.length target