diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +1.1.5 +------- +* Show effects of control-modifiers inline when composing chat messages +* Show time since last transmitted ping +* Automatically split long chat messages + 1.1.4 ------- * Support host-specific server-certificate sections diff --git a/driver/ImageUtils.hs b/driver/ImageUtils.hs --- a/driver/ImageUtils.hs +++ b/driver/ImageUtils.hs @@ -19,7 +19,8 @@ data Formatting = Formatting { _fmtFore :: Maybe Color , _fmtBack :: Maybe Color - , _fmtBold, _fmtItalic, _fmtUnderline, _fmtReverse :: !Bool + , _fmtBold, _fmtItalic, _fmtUnderline, _fmtReverse + , _fmtExplicit :: !Bool } makeLenses ''Formatting @@ -57,26 +58,43 @@ where (a,b) = Text.break isControl t + normalFormatting = defaultFormatting { _fmtExplicit = view fmtExplicit fmt } + + explicit img + | view fmtExplicit fmt = img + | otherwise = emptyImage + rest = case Text.uncons b of Nothing -> emptyImage - Just ('\x02',xs) -> ircFormattedText' (over fmtBold not fmt) xs - Just ('\x0F',xs) -> ircFormattedText' defaultFormatting xs - Just ('\x16',xs) -> ircFormattedText' (over fmtReverse not fmt) xs - Just ('\x1D',xs) -> ircFormattedText' (over fmtItalic not fmt) xs - Just ('\x1F',xs) -> ircFormattedText' (over fmtUnderline not fmt) xs - Just ('\x03',xs) - | Just (fore,xs1) <- colorNumber xs -> - case Text.uncons xs1 of - Just (',',xs2) - | Just (back,xs3) <- colorNumber xs2 -> ircFormattedText' - (set fmtFore (Just fore) - (set fmtBack (Just back) fmt)) xs3 - _ -> ircFormattedText' (set fmtFore (Just fore) - (set fmtBack Nothing fmt)) xs1 - | otherwise -> ircFormattedText' (set fmtFore Nothing (set fmtBack Nothing fmt)) xs + Just (b', xs) -> + explicit (explicitControlImage b') <|> + case b' of + '\^B' -> ircFormattedText' (over fmtBold not fmt) xs + '\^O' -> ircFormattedText' normalFormatting xs + '\^V' -> ircFormattedText' (over fmtReverse not fmt) xs + '\^]' -> ircFormattedText' (over fmtItalic not fmt) xs + '\^_' -> ircFormattedText' (over fmtUnderline not fmt) xs + '\^C' + | Just (fore,xs1) <- colorNumber xs -> + case Text.uncons xs1 of + Just (',',xs2) + | Just (back,xs3) <- colorNumber xs2 -> + explicit (colorNumbers xs3) <|> + ircFormattedText' + (set fmtFore (Just fore) + (set fmtBack (Just back) fmt)) xs3 - Just (_,xs) -> ircFormattedText' fmt xs + _ -> explicit (colorNumbers xs1) <|> + ircFormattedText' + (set fmtFore (Just fore) + (set fmtBack Nothing fmt)) xs1 + | otherwise -> ircFormattedText' (set fmtFore Nothing (set fmtBack Nothing fmt)) xs + where + colorNumbers t = text' defAttr (Text.take (Text.length xs - Text.length t) xs) + + _ -> ircFormattedText' fmt xs + colorNumber :: Text -> Maybe (Color, Text) colorNumber t = do (c1,c2,t1) <- splitNumber t @@ -121,8 +139,12 @@ , _fmtItalic = False , _fmtUnderline = False , _fmtReverse = False + , _fmtExplicit = False } +explicitFormatting :: Formatting +explicitFormatting = defaultFormatting { _fmtExplicit = True } + formattingAttr :: Formatting -> Attr formattingAttr fmt = addForeColor @@ -158,12 +180,16 @@ case break isControl xs of (a,[]) -> string attr a (a,b:bs) -> string attr a - <|> char (withStyle attr reverseVideo) - (controls ! fromEnum b) + <|> explicitControlImage b <|> stringWithControls attr bs - where - controls = listArray (0,0x1f) ('@':['A'..'Z']++"[\\]^_") +explicitControlImage :: Char -> Image +explicitControlImage x = + char (withStyle defAttr reverseVideo) + (controlNames ! fromEnum x) + +controlNames :: Array Int Char +controlNames = listArray (0,0x1f) ('@':['A'..'Z']++"[\\]^_") nameHighlighter :: ByteString -> Set Identifier -> Identifier -> [Color] -> Image diff --git a/driver/Main.hs b/driver/Main.hs --- a/driver/Main.hs +++ b/driver/Main.hs @@ -185,7 +185,8 @@ driver :: Vty -> TChan Event -> TChan (UTCTime, MsgFromServer) -> ClientState -> IO () driver vty vtyEventChan ircMsgChan st0 = - do let (scroll', pic) = picForState st0 + do now <- getCurrentTime + let (scroll', pic) = picForState now st0 st1 = set clientScrollPos scroll' st0 update vty pic e <- readEitherTChan vtyEventChan ircMsgChan @@ -207,9 +208,9 @@ processTimerEvent e st = case e of TransmitPing -> - do sendTimestampPing st - st' <- schedulePing st - considerTimers st' + do st1 <- sendTimestampPing st + st2 <- schedulePing st1 + considerTimers st2 DropOperator chan -> do clientSend (modeCmd chan ["-o",views connNick idBytes conn]) st @@ -285,7 +286,9 @@ '/':_ -> case commandEvent st of (img, Nothing) -> (img, return (KeepGoing st)) (img, Just m ) -> (img, m) - txt -> (stringWithControls defAttr txt, fmap KeepGoing (doSendMessageCurrent SendPriv st)) + txt -> ( ircFormattedText' explicitFormatting (Text.pack txt) + , fmap KeepGoing (doSendMessageCurrent SendPriv st) + ) keyEvent :: Key -> [Modifier] -> ClientState -> IO KeyEventResult keyEvent k ms st = @@ -355,6 +358,18 @@ doSendMessage sendType c (Text.pack (clientInput st)) st _ -> return st +-- Pessimistic maximum length computation for the message part for +-- privmsg and notice. Note that the need for the limit is because +-- the server will limit the length of the message sent out to each +-- client, not just the length of the messages it will recieve. +computeMaxMessageLength :: Identifier -> String -> Identifier -> Int +computeMaxMessageLength nick user target + = 512 + - 63 -- max hostname + - length (":~!@ PRIVMSG :\r\n"::String) + - B8.length (idBytes nick) + - length user + - B8.length (idBytes target) doSendMessage :: SendType -> Identifier -> Text -> ClientState -> IO ClientState @@ -363,22 +378,29 @@ doSendMessage sendType target message st = do let bs = case sendType of - SendPriv -> privMsgCmd target (Text.encodeUtf8 message) - SendAction -> privMsgCmd target ("\SOHACTION " <> - Text.encodeUtf8 message <> "\SOH") - SendNotice -> noticeCmd target (Text.encodeUtf8 message) - SendCtcp cmd -> ctcpRequestCmd target + SendPriv -> map (privMsgCmd target . Text.encodeUtf8) messages + -- long actions aren't split up + SendAction -> [privMsgCmd target ("\SOHACTION " <> + Text.encodeUtf8 message <> "\SOH")] + SendNotice -> map (noticeCmd target . Text.encodeUtf8) messages + SendCtcp cmd -> [ctcpRequestCmd target (Text.encodeUtf8 (Text.pack (map toUpper cmd))) - (Text.encodeUtf8 message) - clientSend bs st + (Text.encodeUtf8 message)] + mapM_ (`clientSend` st) bs now <- getCurrentTime - let myNick = view connNick conn - myModes = view (connChannels . ix target' . chanUsers . ix myNick) conn + let myModes = view (connChannels . ix target' . chanUsers . ix myNick) conn return (addMessage target' (fakeMsg now myModes) (clearInput st)) where - conn = view (clientServer0 . ccConnection) st + myNick = view connNick conn + maxMessageLength = + computeMaxMessageLength myNick (view (ccServerSettings.ssUser) ircconn) target + messages = Text.chunksOf maxMessageLength message + + ircconn = view clientServer0 st + conn = view ccConnection ircconn + (statusmsg, target') = splitStatusMsg target conn fakeMsg now modes = IrcMessage @@ -587,14 +609,14 @@ , ("reconnect", [], pure (doReconnect st')) , ("ping", [], - (\msg -> st' <$ doPingCmd msg st') + (\msg -> doPingCmd msg st') <$> pRemainingNoSp) ] -doPingCmd :: String -> ClientState -> IO () +doPingCmd :: String -> ClientState -> IO ClientState doPingCmd "" st = sendTimestampPing st -doPingCmd msg st = clientSend (pingCmd (Text.encodeUtf8 (Text.pack msg))) st +doPingCmd msg st = st <$ clientSend (pingCmd (Text.encodeUtf8 (Text.pack msg))) st doReconnect :: ClientState -> IO ClientState doReconnect st = @@ -737,8 +759,8 @@ -- Primary UI rendering ------------------------------------------------------------------------ -picForState :: ClientState -> (Int,Picture) -picForState st = (scroll', pic) +picForState :: UTCTime -> ClientState -> (Int,Picture) +picForState now st = (scroll', pic) where conn = view (clientServer0 . ccConnection) st @@ -760,7 +782,7 @@ , mainFocusImage ] - divider = dividerImage st + divider = dividerImage now st -- Pad the main image when it doesn't fill the screen -- so that it starts at the bottom of the frame @@ -841,26 +863,29 @@ beginning = char (withForeColor defAttr brightBlack) '^' ending = char (withForeColor defAttr brightBlack) '$' -dividerImage :: ClientState -> Image -dividerImage st +dividerImage :: UTCTime -> ClientState -> Image +dividerImage now st = extendToWidth (nickPart <|> channelPart <|> lagPart) where conn = view (clientServer0 . ccConnection) st myNick = view connNick conn - lagPart = - case view connPingTime conn of - Just s -> + drawLagTime color s = let s' = realToFrac s :: Centi -- truncate to two decimal places sStr = showFixed True s' <> "s" in string defAttr "-[" - <|> string (withForeColor defAttr yellow) sStr + <|> string (withForeColor defAttr color) sStr <|> string defAttr "]" - _ -> emptyImage + lagPart = + case view connPingTime conn of + NoPing -> emptyImage + PingSent when -> drawLagTime red (realToFrac (diffUTCTime now when)) + PingTime s -> drawLagTime yellow s + channelPart = ifoldr (\i x xs -> drawOne i x <|> xs) emptyImage @@ -1050,10 +1075,11 @@ let pingTime = addUTCTime 60 now return (addTimerEvent pingTime TransmitPing st) -sendTimestampPing :: ClientState -> IO () +sendTimestampPing :: ClientState -> IO ClientState sendTimestampPing st = do now <- getCurrentTime let ts = realToFrac (utcTimeToPOSIXSeconds now) :: Pico chopTrailingZeros = True tsStr = B8.pack (showFixed chopTrailingZeros ts) clientSend (pingCmd tsStr) st + return $! set (clientServer0.ccConnection.connPingTime) (PingSent now) st 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.1.4 +version: 1.1.5 homepage: https://github.com/glguy/irc-core bug-reports: https://github.com/glguy/irc-core/issues license: BSD3 @@ -97,7 +97,7 @@ base64-bytestring>= 1.0.0.1 && < 1.1, containers >= 0.5 && < 0.6, free >= 4.11 && < 4.13, - lens >= 4.7 && < 4.14, + lens >= 4.7 && < 4.15, text >= 1.2.0.4 && < 1.3, transformers >= 0.2 && < 0.6, regex-tdfa >= 1.2 && < 1.3 @@ -134,7 +134,7 @@ connection >= 0.2.4 && < 0.3, tls >= 1.2.16 && < 1.4, - data-default-class >= 0.0.1 && < 0.1, + data-default-class >= 0.0.1 && < 0.2, x509 >= 1.5.0.1 && < 1.7, x509-system >= 1.5.0 && < 1.7, x509-store >= 1.5.0 && < 1.7, @@ -148,12 +148,12 @@ 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.14, + lens >= 4.7 && < 4.15, network >= 2.6.0.2 && < 2.7, split >= 0.2.2 && < 0.3, stm >= 2.4.4 && < 2.5, text >= 1.2.0.4 && < 1.3, - vty >= 5.2.7 && < 5.5, + vty >= 5.2.7 && < 5.6, haskell-lexer >= 1.0 && < 1.1, transformers >= 0.2 && < 0.6, regex-tdfa >= 1.2 && < 1.3 diff --git a/src/Irc/Model.hs b/src/Irc/Model.hs --- a/src/Irc/Model.hs +++ b/src/Irc/Model.hs @@ -34,6 +34,9 @@ , connPingTime , defaultIrcConnection + -- * Ping information + , PingStatus(..) + -- * Phases , Phase(..) @@ -141,10 +144,13 @@ , _connUmode :: !ByteString , _connSnoMask :: !ByteString , _connPhase :: !Phase - , _connPingTime :: Maybe Pico -- No read instance for NominalDiffTime + , _connPingTime :: !PingStatus } deriving (Read, Show) +data PingStatus = PingTime Pico | PingSent UTCTime | NoPing + deriving (Read, Show) + -- | 'IrcConnection' value with everything unspecified defaultIrcConnection :: IrcConnection defaultIrcConnection = IrcConnection @@ -167,7 +173,7 @@ , _connUmode = "" , _connSnoMask = "" , _connPhase = RegistrationPhase - , _connPingTime = Nothing + , _connPingTime = NoPing } data Phase @@ -280,7 +286,7 @@ do now <- getStamp let past = posixSecondsToUTCTime (realToFrac (sec :: Pico)) delta = realToFrac (now `diffUTCTime` past) - return (set connPingTime (Just delta) conn) + return (set connPingTime (PingTime delta) conn) Pong mbServer msg -> doServerMessage "Pong" (maybe "" (<>" ") mbServer <> msg) conn