diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +1.1 +--- +* Better support for Freenode's trailing spaces +* More compact metadata representation +* Ignored messages no longer count toward unread number +* Updated version bounds on lens and attoparsec +* Channel info has user count + 1.0 --- * Initial hackage release diff --git a/driver/ClientState.hs b/driver/ClientState.hs --- a/driver/ClientState.hs +++ b/driver/ClientState.hs @@ -231,12 +231,18 @@ where conn = view (clientServer0 . ccConnection) st + isIgnored nick = view (clientIgnores . contains nick) st + aux = case views mesgType isRelevant message of Nothing -> over mlMessages (cons (message,error "unused colored message")) - Just txt -> over mlNewMessages (+1) - . over mlMentioned (|| mention txt || private) + Just txt -> updateMessageCount . over mlMessages (cons (message,coloredImage)) where + updateMessageCount + | isIgnored (views mesgSender userNick message) = id + | otherwise = over mlNewMessages (+1) + . over mlMentioned (|| mention txt || private) + !coloredImage | Text.any isControl txt = cleanText txt | otherwise = force -- avoid holding on to old channel lists diff --git a/driver/Views/Channel.hs b/driver/Views/Channel.hs --- a/driver/Views/Channel.hs +++ b/driver/Views/Channel.hs @@ -6,7 +6,7 @@ import Control.Lens import Data.Monoid import Data.Foldable (toList) -import Data.List (stripPrefix) +import Data.List (stripPrefix, intersperse) import Data.Text (Text) import Data.Time (TimeZone, UTCTime, formatTime, utcToZonedTime) import Graphics.Vty.Image @@ -115,7 +115,7 @@ renderOne ((msg,colored):msgs) = case mbImg of Just img -> (timestamp <|> img) : renderOne msgs - Nothing -> renderMeta emptyImage ((msg,colored):msgs) + Nothing -> renderMeta ((msg,colored):msgs) where timestamp @@ -213,59 +213,27 @@ | view clientMetaView st = [x] | otherwise = [] - renderMeta img [] = filterMeta (cropRight width img) - renderMeta img ((msg,colored):msgs) = - let who = views mesgSender userNick msg - visible = not (view (contains who) ignores) - metaAttr = withForeColor defAttr brightBlack - in case view mesgType msg of - CtcpReqMsgType{} -> - renderMeta - (img <|> - char (withForeColor defAttr brightBlue) 'C' <|> - identImg metaAttr who <|> - char defAttr ' ') msgs - JoinMsgType -> - renderMeta - (img <|> - char (withForeColor defAttr green) '+' <|> - identImg metaAttr who <|> - char defAttr ' ') msgs - PartMsgType{} -> - renderMeta - (img <|> - char (withForeColor defAttr red) '-' <|> - identImg metaAttr who <|> - char defAttr ' ') msgs - QuitMsgType{} -> - renderMeta - (img <|> - char (withForeColor defAttr red) 'x' <|> - identImg metaAttr who <|> - char defAttr ' ') msgs - NickMsgType who' -> - renderMeta - (img <|> - identImg metaAttr who <|> - char (withForeColor defAttr yellow) '-' <|> - identImg metaAttr who' <|> - char defAttr ' ') msgs - KnockMsgType -> - renderMeta - (img <|> - char (withForeColor defAttr yellow) 'K' <|> - identImg metaAttr who <|> - char defAttr ' ') msgs - _ | not visible -> - renderMeta - (img <|> - char (withForeColor defAttr brightBlack) 'I' <|> - identImg metaAttr who <|> - char defAttr ' ') msgs - | otherwise -> - filterMeta (cropRight width img) - ++ renderOne ((msg,colored):msgs) + renderMeta msgs = filterMeta (cropRight width img) + ++ renderOne rest + where + (mds,rest) = splitWith (processMeta . fst) msgs + mds1 = mergeMetadatas mds + img = horizCat (intersperse gap (map renderCompressed mds1)) + gap = char defAttr ' ' + processMeta msg = + case view mesgType msg of + CtcpReqMsgType{} -> Just $ SimpleMetadata (char (withForeColor defAttr brightBlue) 'C') who + JoinMsgType -> Just $ SimpleMetadata (char (withForeColor defAttr green) '+') who + PartMsgType{} -> Just $ SimpleMetadata (char (withForeColor defAttr red) '-') who + QuitMsgType{} -> Just $ SimpleMetadata (char (withForeColor defAttr red) 'x') who + KnockMsgType -> Just $ SimpleMetadata (char (withForeColor defAttr yellow) 'K') who + NickMsgType who' -> Just $ NickChange who who' + _ | not visible -> Just $ SimpleMetadata (char (withForeColor defAttr yellow) 'I') who + | otherwise -> Nothing + where + who = views mesgSender userNick msg + visible = not (view (contains who) ignores) conn = view (clientServer0 . ccConnection) st @@ -275,7 +243,21 @@ string (withForeColor defAttr blue) [ prefix | (mode,prefix) <- prefixes, mode `elem` modes] +data CompressedMetadata + = SimpleMetadata Image Identifier + | NickChange Identifier Identifier +renderCompressed :: CompressedMetadata -> Image +renderCompressed md = + case md of + SimpleMetadata img who -> img <|> identImg metaAttr who + NickChange who who' -> + identImg metaAttr who <|> + char (withForeColor defAttr yellow) '-' <|> + identImg metaAttr who' + where + metaAttr = withForeColor defAttr brightBlack + statusMsgImage :: String -> Image statusMsgImage status | null status = emptyImage @@ -349,3 +331,17 @@ ErrTargUmodeG -> "Message ignored by +g mode" ErrNoPrivs priv -> "Oper privilege required: " <> asUtf8 priv ErrMlockRestricted m ms -> "Mode '" <> Text.singleton m <> "' in locked set \"" <> asUtf8 ms <> "\"" + +splitWith :: (a -> Maybe b) -> [a] -> ([b],[a]) +splitWith f [] = ([],[]) +splitWith f (x:xs) = + case f x of + Nothing -> ([],x:xs) + Just y -> case splitWith f xs of + (ys,xs') -> (y:ys, xs') + +mergeMetadatas :: [CompressedMetadata] -> [CompressedMetadata] +mergeMetadatas (SimpleMetadata img1 who1 : SimpleMetadata img2 who2 : xs) + | who1 == who2 = mergeMetadatas (SimpleMetadata (img1 <|> img2) who1 : xs) +mergeMetadatas (x:xs) = x : mergeMetadatas xs +mergeMetadatas [] = [] diff --git a/driver/Views/ChannelInfo.hs b/driver/Views/ChannelInfo.hs --- a/driver/Views/ChannelInfo.hs +++ b/driver/Views/ChannelInfo.hs @@ -68,7 +68,9 @@ usersLines = return $ horizCat - $ string (withForeColor defAttr green) "Users:" + $ string (withForeColor defAttr green) "Users (" + : string defAttr (show (Map.size (view chanUsers channel))) + : string (withForeColor defAttr green) "):" : [ char defAttr ' ' <|> modePrefix modes <|> identImg defAttr nick diff --git a/irc-core.cabal b/irc-core.cabal --- a/irc-core.cabal +++ b/irc-core.cabal @@ -1,5 +1,5 @@ name: irc-core -version: 1.0 +version: 1.1 homepage: https://github.com/glguy/irc-core bug-reports: https://github.com/glguy/irc-core/issues license: BSD3 @@ -91,7 +91,7 @@ build-depends: base >= 4.7.0.2 && < 4.9, array >= 0.5 && < 0.6, - attoparsec >= 0.12.1.2 && < 0.13, + attoparsec >= 0.12.1.2 && < 0.14, bytestring >= 0.10 && < 0.11, base64-bytestring>= 1.0.0.1 && < 1.1, containers >= 0.5 && < 0.6, @@ -144,7 +144,7 @@ deepseq >= 1.3.0.2 && < 1.5, directory >= 1.2.1.0 && < 1.3, filepath >= 1.3.0.2 && < 1.5, - lens >= 4.7 && < 4.9, + lens >= 4.7 && < 4.10, network >= 2.6.0.2 && < 2.7, old-locale >= 1.0.0.6 && < 1.1, split >= 0.2.2 && < 0.3, diff --git a/src/Irc/Cmd.hs b/src/Irc/Cmd.hs --- a/src/Irc/Cmd.hs +++ b/src/Irc/Cmd.hs @@ -27,6 +27,7 @@ , whowasCmd , whoCmd , pongCmd + , pingCmd , capLsCmd , capReqCmd , capEndCmd @@ -175,6 +176,18 @@ userCmd user realname = renderRawIrcMsg outgoingMsg { msgCommand = "USER" , msgParams = [user,"0","*",realname] + } + +-- | Construct a PING command. This is used to respond to the PING +-- command to keep a connection alive. +-- +-- @PONG token@ +pingCmd :: + ByteString {- ^ token -} -> + ByteString +pingCmd token = renderRawIrcMsg outgoingMsg + { msgCommand = "PING" + , msgParams = [token] } -- | Construct a PONG command. This is used to respond to the PING diff --git a/src/Irc/Format.hs b/src/Irc/Format.hs --- a/src/Irc/Format.hs +++ b/src/Irc/Format.hs @@ -142,7 +142,7 @@ -- allows for up to 15 parameters. paramsParser :: Int -> Parser [ByteString] paramsParser n = - do _ <- optional (char ' ') -- Freenode requires this exception + do _ <- skipMany (char ' ') -- Freenode requires this exception endOfInput $> [] <|> more where more