{-# Language OverloadedStrings, BangPatterns #-}
module Client.Image.Message
( MessageRendererParams(..)
, RenderMode(..)
, IdentifierColorMode(..)
, defaultRenderParams
, msgImage
, metadataImg
, ignoreImage
, quietIdentifier
, coloredUserInfo
, coloredIdentifier
, cleanText
, cleanChar
, rightPad
) where
import Client.Image.MircFormatting
import Client.Image.Palette
import Client.Message
import Control.Lens
import Data.Char
import Data.Hashable (hash)
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.List
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time
import qualified Data.Vector as Vector
import Graphics.Vty.Attributes
import Graphics.Vty.Image
import Irc.Codes
import Irc.Identifier
import Irc.Message
import Irc.RawIrcMsg
import Irc.UserInfo
import Text.Read
data MessageRendererParams = MessageRendererParams
{ rendStatusMsg :: [Char]
, rendUserSigils :: [Char]
, rendNicks :: HashSet Identifier
, rendMyNicks :: HashSet Identifier
, rendPalette :: Palette
, rendNickPadding :: Maybe Integer
}
defaultRenderParams :: MessageRendererParams
defaultRenderParams = MessageRendererParams
{ rendStatusMsg = ""
, rendUserSigils = ""
, rendNicks = HashSet.empty
, rendMyNicks = HashSet.empty
, rendPalette = defaultPalette
, rendNickPadding = Nothing
}
msgImage ::
RenderMode ->
ZonedTime ->
MessageRendererParams -> MessageBody -> Image
msgImage rm when params body = horizCat
[ renderTime rm (rendPalette params) when
, statusMsgImage (rendStatusMsg params)
, bodyImage rm params body
]
cleanChar :: Char -> Char
cleanChar x
| x < '\x20' = chr (0x2400 + ord x)
| x == '\DEL' = '␡'
| isControl x = '�'
| otherwise = x
cleanText :: Text -> Text
cleanText = Text.map cleanChar
errorImage ::
MessageRendererParams ->
Text ->
Image
errorImage params txt = horizCat
[ text' (view palError (rendPalette params)) "error "
, text' defAttr (cleanText txt)
]
normalImage ::
MessageRendererParams ->
Text ->
Image
normalImage params txt = horizCat
[ text' (view palLabel (rendPalette params)) "client "
, text' defAttr (cleanText txt)
]
renderTime :: RenderMode -> Palette -> ZonedTime -> Image
renderTime DetailedRender = datetimeImage
renderTime NormalRender = timeImage
statusMsgImage :: [Char] -> Image
statusMsgImage modes
| null modes = emptyImage
| otherwise = string defAttr "(" <|>
string statusMsgColor modes <|>
string defAttr ") "
where
statusMsgColor = withForeColor defAttr red
bodyImage ::
RenderMode ->
MessageRendererParams ->
MessageBody -> Image
bodyImage rm params body =
case body of
IrcBody irc -> ircLineImage rm params irc
ErrorBody txt -> errorImage params txt
NormalBody txt -> normalImage params txt
timeImage :: Palette -> ZonedTime -> Image
timeImage palette
= string (view palTime palette)
. formatTime defaultTimeLocale "%R "
datetimeImage :: Palette -> ZonedTime -> Image
datetimeImage palette
= string (view palTime palette)
. formatTime defaultTimeLocale "%F %T "
data RenderMode
= NormalRender
| DetailedRender
rightPad :: RenderMode -> Maybe Integer -> Image -> Image
rightPad NormalRender (Just minWidth) i =
let w = max 0 (fromIntegral minWidth - imageWidth i)
in i <|> string defAttr (replicate w ' ')
rightPad _ _ i = i
ircLineImage ::
RenderMode ->
MessageRendererParams ->
IrcMsg -> Image
ircLineImage rm !rp body =
let quietAttr = view palMeta pal
pal = rendPalette rp
sigils = rendUserSigils rp
myNicks = rendMyNicks rp
nicks = rendNicks rp
detail img =
case rm of
NormalRender -> emptyImage
DetailedRender -> img
in
case body of
Nick old new ->
detail (string quietAttr "nick ") <|>
string (view palSigil pal) sigils <|>
coloredUserInfo pal rm myNicks old <|>
string defAttr " is now known as " <|>
coloredIdentifier pal NormalIdentifier myNicks new
Join nick _chan ->
string quietAttr "join " <|>
coloredUserInfo pal rm myNicks nick
Part nick _chan mbreason ->
string quietAttr "part " <|>
coloredUserInfo pal rm myNicks nick <|>
foldMap (\reason -> string quietAttr " (" <|>
parseIrcText reason <|>
string quietAttr ")") mbreason
Quit nick mbreason ->
string quietAttr "quit " <|>
coloredUserInfo pal rm myNicks nick <|>
foldMap (\reason -> string quietAttr " (" <|>
parseIrcText reason <|>
string quietAttr ")") mbreason
Kick kicker _channel kickee reason ->
detail (string quietAttr "kick ") <|>
string (view palSigil pal) sigils <|>
coloredUserInfo pal rm myNicks kicker <|>
string defAttr " kicked " <|>
coloredIdentifier pal NormalIdentifier myNicks kickee <|>
string defAttr ": " <|>
parseIrcText reason
Topic src _dst txt ->
detail (string quietAttr "tpic ") <|>
coloredUserInfo pal rm myNicks src <|>
string defAttr " changed the topic to: " <|>
parseIrcText txt
Notice src _dst txt ->
detail (string quietAttr "note ") <|>
rightPad rm (rendNickPadding rp)
(string (view palSigil pal) sigils <|>
coloredUserInfo pal rm myNicks src) <|>
string (withForeColor defAttr red) ": " <|>
parseIrcTextWithNicks pal myNicks nicks txt
Privmsg src _dst txt ->
detail (string quietAttr "chat ") <|>
rightPad rm (rendNickPadding rp)
(string (view palSigil pal) sigils <|>
coloredUserInfo pal rm myNicks src) <|>
string defAttr ": " <|>
parseIrcTextWithNicks pal myNicks nicks txt
Ctcp src _dst "ACTION" txt ->
detail (string quietAttr "actp ") <|>
string (withForeColor defAttr blue) "* " <|>
string (view palSigil pal) sigils <|>
coloredUserInfo pal rm myNicks src <|>
string defAttr " " <|>
parseIrcTextWithNicks pal myNicks nicks txt
CtcpNotice src _dst "ACTION" txt ->
detail (string quietAttr "actn ") <|>
string (withForeColor defAttr red) "* " <|>
string (view palSigil pal) sigils <|>
coloredUserInfo pal rm myNicks src <|>
string defAttr " " <|>
parseIrcTextWithNicks pal myNicks nicks txt
Ctcp src _dst cmd txt ->
detail (string quietAttr "ctcp ") <|>
string (withForeColor defAttr blue) "! " <|>
string (view palSigil pal) sigils <|>
coloredUserInfo pal rm myNicks src <|>
string defAttr " " <|>
parseIrcText cmd <|>
separatorImage <|>
parseIrcText txt
CtcpNotice src _dst cmd txt ->
detail (string quietAttr "ctcp ") <|>
string (withForeColor defAttr red) "! " <|>
string (view palSigil pal) sigils <|>
coloredUserInfo pal rm myNicks src <|>
string defAttr " " <|>
parseIrcText cmd <|>
separatorImage <|>
parseIrcText txt
Ping params ->
string defAttr "PING " <|> separatedParams params
Pong params ->
string defAttr "PONG " <|> separatedParams params
Error reason ->
string (view palError pal) "ERROR " <|>
parseIrcText reason
Reply code params ->
renderReplyCode rm rp code params
UnknownMsg irc ->
maybe emptyImage (\ui -> coloredUserInfo pal rm myNicks ui <|> char defAttr ' ')
(view msgPrefix irc) <|>
text' defAttr (view msgCommand irc) <|>
char defAttr ' ' <|>
separatedParams (view msgParams irc)
Cap cmd args ->
text' (withForeColor defAttr magenta) (renderCapCmd cmd) <|>
text' defAttr ": " <|>
separatedParams args
Mode nick _chan params ->
detail (string quietAttr "mode ") <|>
string (view palSigil pal) sigils <|>
coloredUserInfo pal rm myNicks nick <|>
string defAttr " set mode: " <|>
ircWords params
Authenticate{} -> string defAttr "AUTHENTICATE ***"
BatchStart{} -> string defAttr "BATCH +"
BatchEnd{} -> string defAttr "BATCH -"
renderCapCmd :: CapCmd -> Text
renderCapCmd cmd =
case cmd of
CapLs -> "caps available"
CapList -> "caps active"
CapAck -> "caps acknowledged"
CapNak -> "caps rejected"
CapEnd -> "caps finished"
CapReq -> "caps requested"
separatorImage :: Image
separatorImage = char (withForeColor defAttr blue) '·'
separatedParams :: [Text] -> Image
separatedParams = horizCat . intersperse separatorImage . map parseIrcText
ircWords :: [Text] -> Image
ircWords = horizCat . intersperse (char defAttr ' ') . map parseIrcText
renderReplyCode :: RenderMode -> MessageRendererParams -> ReplyCode -> [Text] -> Image
renderReplyCode rm rp code@(ReplyCode w) params =
case rm of
DetailedRender -> string attr (show w) <|> rawParamsImage
NormalRender ->
rightPad rm (rendNickPadding rp)
(text' attr (Text.toLower (replyCodeText info))) <|>
char defAttr ':' <|>
case code of
RPL_WHOISIDLE -> whoisIdleParamsImage
_ -> rawParamsImage
where
rawParamsImage =
char defAttr ' ' <|>
separatedParams params'
params' = case rm of
DetailedRender -> params
NormalRender -> drop 1 params
info = replyCodeInfo code
color = case replyCodeType info of
ClientServerReply -> magenta
CommandReply -> green
ErrorReply -> red
UnknownReply -> yellow
attr = withForeColor defAttr color
whoisIdleParamsImage =
case params' of
[name, idle, signon, _txt] ->
char defAttr ' ' <|>
text' defAttr name <|>
text' defAttr " idle: " <|>
string defAttr (prettySeconds (Text.unpack idle)) <|>
text' defAttr " sign-on: " <|>
string defAttr (prettyUnixTime (Text.unpack signon))
_ -> rawParamsImage
prettyUnixTime :: String -> String
prettyUnixTime str =
case parseTimeM False defaultTimeLocale "%s" str of
Nothing -> str
Just t -> formatTime defaultTimeLocale "%A %B %e, %Y %H:%M:%S %Z" (t :: UTCTime)
prettySeconds :: String -> String
prettySeconds str =
case readMaybe str of
Nothing -> str
Just n -> intercalate " "
$ map (\(u,i) -> show i ++ [u])
$ dropWhile (\x -> snd x == 0)
$ zip "dhms" [d,h,m,s]
where
(n1,s) = quotRem n 60
(n2,m) = quotRem n1 60
(d ,h) = quotRem n2 24
data IdentifierColorMode
= PrivmsgIdentifier
| NormalIdentifier
coloredIdentifier ::
Palette ->
IdentifierColorMode ->
HashSet Identifier ->
Identifier ->
Image
coloredIdentifier palette icm myNicks ident =
text' color (idText ident)
where
color
| ident `HashSet.member` myNicks =
case icm of
PrivmsgIdentifier -> view palSelfHighlight palette
NormalIdentifier -> view palSelf palette
| otherwise = v Vector.! i
v = view palNicks palette
i = hash ident `mod` Vector.length v
coloredUserInfo ::
Palette ->
RenderMode ->
HashSet Identifier ->
UserInfo ->
Image
coloredUserInfo palette NormalRender myNicks ui =
coloredIdentifier palette NormalIdentifier myNicks (userNick ui)
coloredUserInfo palette DetailedRender myNicks !ui =
horizCat
[ coloredIdentifier palette NormalIdentifier myNicks (userNick ui)
, aux '!' (userName ui)
, aux '@' (userHost ui)
]
where
quietAttr = view palMeta palette
aux x xs
| Text.null xs = emptyImage
| otherwise = char quietAttr x <|> text' quietAttr xs
quietIdentifier :: Palette -> Identifier -> Image
quietIdentifier palette ident =
text' (view palMeta palette) (idText ident)
parseIrcTextWithNicks ::
Palette ->
HashSet Identifier ->
HashSet Identifier ->
Text -> Image
parseIrcTextWithNicks palette myNicks nicks txt
| Text.any isControl txt = parseIrcText txt
| otherwise = highlightNicks palette myNicks nicks txt
highlightNicks ::
Palette ->
HashSet Identifier ->
HashSet Identifier ->
Text -> Image
highlightNicks palette myNicks nicks txt = horizCat (highlight1 <$> txtParts)
where
txtParts = nickSplit txt
allNicks = HashSet.union myNicks nicks
highlight1 part
| HashSet.member partId allNicks = coloredIdentifier palette PrivmsgIdentifier myNicks partId
| otherwise = text' defAttr part
where
partId = mkId part
metadataImg :: IrcSummary -> Maybe (Image, Identifier, Maybe Identifier)
metadataImg msg =
case msg of
QuitSummary who -> Just (char (withForeColor defAttr red ) 'x', who, Nothing)
PartSummary who -> Just (char (withForeColor defAttr red ) '-', who, Nothing)
JoinSummary who -> Just (char (withForeColor defAttr green ) '+', who, Nothing)
CtcpSummary who -> Just (char (withForeColor defAttr white ) 'C', who, Nothing)
NickSummary old new -> Just (char (withForeColor defAttr yellow) '>', old, Just new)
_ -> Nothing
ignoreImage :: Image
ignoreImage = char (withForeColor defAttr yellow) 'I'