diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for glirc2 +## 2.27 +* Requires GHC 8.4 +* Show channel topic in channel on join +* Fix socket leak when failing to load TLS certificates +* Add delay when indicating sent ping to reduce noise + ## 2.26 * Updates for GHC 8.4.1 * Added `/toggle-show-ping` and `show-ping` configuration setting diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,5 +1,5 @@ name: glirc -version: 2.26 +version: 2.27 synopsis: Console IRC client description: Console IRC client . @@ -23,7 +23,7 @@ tested-with: GHC==8.0.2 custom-setup - setup-depends: base >=4.9 && <4.12, + setup-depends: base >=4.11 && <4.12, filepath >=1.4 && <1.5, Cabal >=1.24 && <2.3 @@ -124,7 +124,7 @@ Paths_glirc Build_glirc - build-depends: base >=4.9 && <4.12, + build-depends: base >=4.11 && <4.12, HsOpenSSL >=0.11 && <0.12, async >=2.1 && <2.3, attoparsec >=0.13 && <0.14, @@ -132,21 +132,20 @@ bytestring >=0.10.8 && <0.11, config-schema >=0.4 && <0.6, config-value >=0.6 && <0.7, - containers >=0.5.7 && <0.6, + containers >=0.5.7 && <0.7, directory >=1.2.6 && <1.4, filepath >=1.4.1 && <1.5, - free >=4.12 && <5.1, + free >=4.12 && <5.2, gitrev >=1.2 && <1.4, hashable >=1.2.4 && <1.3, - hookup >=0.2 && <0.3, + hookup >=0.2.2 && <0.3, irc-core >=2.3 && <2.4, - kan-extensions >=5.0 && <5.2, - lens >=4.14 && <4.17, - network >=2.6.2 && <2.7, + kan-extensions >=5.0 && <5.3, + lens >=4.14 && <4.18, + network >=2.6.2 && <2.8, process >=1.4.2 && <1.7, regex-tdfa >=1.2 && <1.3, - semigroupoids >=5.1 && <5.3, - socks >=0.5.5 && <0.6, + semigroupoids >=5.1 && <5.4, split >=0.2 && <0.3, stm >=2.4 && <2.5, template-haskell >=2.11 && <2.14, @@ -156,7 +155,7 @@ unix >=2.7 && <2.8, unordered-containers >=0.2.7 && <0.3, vector >=0.11 && <0.13, - vty >=5.11.1 && <5.22 + vty >=5.23.1 && <5.24 test-suite test type: exitcode-stdio-1.0 diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -141,8 +141,9 @@ -- command. Otherwise if a channel or user query is focused a chat message -- will be sent. execute :: - String {- ^ chat or command -} -> - ClientState -> IO CommandResult + String {- ^ chat or command -} -> + ClientState {- ^ client state -} -> + IO CommandResult {- ^ command result -} execute str st = case str of [] -> commandFailure st @@ -150,7 +151,15 @@ msg -> executeChat msg st -- | Execute command provided by user, resolve aliases if necessary. -executeUserCommand :: Maybe Text -> String -> ClientState -> IO CommandResult +-- +-- The last disconnection time is stored in text form and is available +-- for substitutions in macros. It is only provided when running startup +-- commands during a reconnect event. +executeUserCommand :: + Maybe Text {- ^ disconnection time -} -> + String {- ^ command -} -> + ClientState {- ^ client state -} -> + IO CommandResult {- ^ command result -} executeUserCommand discoTime command st = do let key = Text.takeWhile (/=' ') (Text.pack command) rest = dropWhile (==' ') (dropWhile (/=' ') command) @@ -201,14 +210,20 @@ -- | Respond to the TAB key being pressed. This can dispatch to a command -- specific completion mode when relevant. Otherwise this will complete -- input based on the users of the channel related to the current buffer. -tabCompletion :: Bool {- ^ reversed -} -> ClientState -> IO CommandResult +tabCompletion :: + Bool {- ^ reversed -} -> + ClientState {- ^ client state -} -> + IO CommandResult {- ^ command result -} tabCompletion isReversed st = case snd $ clientLine st of '/':command -> executeCommand (Just isReversed) command st _ -> nickTabCompletion isReversed st -- | Treat the current text input as a chat message and send it. -executeChat :: String -> ClientState -> IO CommandResult +executeChat :: + String {- ^ chat message -} -> + ClientState {- ^ client state -} -> + IO CommandResult {- ^ command result -} executeChat msg st = case view clientFocus st of ChannelFocus network channel @@ -236,7 +251,11 @@ -- | Parse and execute the given command. When the first argument is Nothing -- the command is executed, otherwise the first argument is the cursor -- position for tab-completion -executeCommand :: Maybe Bool -> String -> ClientState -> IO CommandResult +executeCommand :: + Maybe Bool {- ^ tab-completion direction -} -> + String {- ^ command -} -> + ClientState {- ^ client state -} -> + IO CommandResult {- ^ command result -} executeCommand (Just isReversed) _ st | Just st' <- commandNameCompletion isReversed st = commandSuccess st' @@ -367,7 +386,7 @@ (remainingArg "arguments") "Execute a command synchnonously sending the to a configuration destination.\n\ \\n\ - \\^Barguments\^B: [-n network] [-c channel] [-i input] command [command arguments...]\n\ + \\^Barguments\^B: [-n[network]] [-c[channel]] [-i input] command [arguments...]\n\ \\n\ \When \^Binput\^B is specified it is sent to the stdin.\n\ \\n\ @@ -389,9 +408,11 @@ \\n\ \The URL is opened using the executable configured under \^Burl-opener\^B.\n\ \\n\ - \When this command is active in the textbox, chat messages are filtered to only show ones with URLs.\n\ + \When this command is active in the textbox, chat messages are filtered to\ + \ only show ones with URLs.\n\ \\n\ - \When \^Bnumber\^B is omitted it defaults to \^B1\^B. The number selects the URL to open counting back from the most recent.\n" + \When \^Bnumber\^B is omitted it defaults to \^B1\^B. The number selects the\ + \ URL to open counting back from the most recent.\n" $ ClientCommand cmdUrl noClientTab , Command @@ -2185,19 +2206,36 @@ buildTransmitter now ec = case (Text.pack <$> view execOutputNetwork ec, Text.pack <$> view execOutputChannel ec) of - (Nothing, Nothing) -> Right (sendToClient now) - (Just network, Nothing) -> + + (Unspecified, Unspecified) -> Right (sendToClient now) + + (Specified network, Specified channel) -> case preview (clientConnection network) st of Nothing -> Left ["Unknown network"] - Just cs -> Right (sendToNetwork now cs) - (Nothing , Just channel) -> + Just cs -> Right (sendToChannel cs channel) + + (_ , Specified channel) -> case currentNetworkState of Nothing -> Left ["No current network"] Just cs -> Right (sendToChannel cs channel) - (Just network, Just channel) -> + + (Specified network, _) -> case preview (clientConnection network) st of Nothing -> Left ["Unknown network"] - Just cs -> Right (sendToChannel cs channel) + Just cs -> Right (sendToNetwork now cs) + + (_, Current) -> + case currentNetworkState of + Nothing -> Left ["No current network"] + Just cs -> + case view clientFocus st of + ChannelFocus _ channel -> Right (sendToChannel cs (idText channel)) + _ -> Left ["No current channel"] + + (Current, _) -> + case currentNetworkState of + Nothing -> Left ["No current network"] + Just cs -> Right (sendToNetwork now cs) sendToClient now msgs = commandSuccess $! foldl' (recordSuccess now) st msgs diff --git a/src/Client/Commands/Exec.hs b/src/Client/Commands/Exec.hs --- a/src/Client/Commands/Exec.hs +++ b/src/Client/Commands/Exec.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, BangPatterns, OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor, TemplateHaskell, BangPatterns, OverloadedStrings #-} {-| Module : Client.Commands @@ -14,6 +14,7 @@ module Client.Commands.Exec ( -- * Exec command configuration ExecCmd(..) + , Target(..) -- * Lenses , execOutputNetwork @@ -44,21 +45,24 @@ -- When the network and channel are specified the output is sent as messages -- to the given channel on the given network. data ExecCmd = ExecCmd - { _execOutputNetwork :: Maybe String -- ^ output network - , _execOutputChannel :: Maybe String -- ^ output channel - , _execCommand :: String -- ^ command filename - , _execStdIn :: String -- ^ stdin source - , _execArguments :: [String] -- ^ command arguments + { _execOutputNetwork :: Target String -- ^ output network + , _execOutputChannel :: Target String -- ^ output channel + , _execCommand :: String -- ^ command filename + , _execStdIn :: String -- ^ stdin source + , _execArguments :: [String] -- ^ command arguments } deriving (Read,Show) +data Target a = Unspecified | Current | Specified a + deriving (Show, Read, Eq, Ord, Functor) + makeLenses ''ExecCmd -- | Default values for @/exec@ to be overridden by flags. emptyExecCmd :: ExecCmd emptyExecCmd = ExecCmd - { _execOutputNetwork = Nothing - , _execOutputChannel = Nothing + { _execOutputNetwork = Unspecified + , _execOutputChannel = Unspecified , _execCommand = error "no default command" , _execStdIn = "" , _execArguments = [] @@ -66,11 +70,12 @@ options :: [OptDescr (ExecCmd -> ExecCmd)] options = + let specified = maybe Current Specified in [ Option "n" ["network"] - (ReqArg (set execOutputNetwork . Just) "NETWORK") + (OptArg (set execOutputNetwork . specified) "NETWORK") "Set network target" , Option "c" ["channel"] - (ReqArg (set execOutputChannel . Just) "CHANNEL") + (OptArg (set execOutputChannel . specified) "CHANNEL") "Set channel target" , Option "i" ["input"] (ReqArg (set execStdIn) "INPUT") diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -87,7 +87,7 @@ data Configuration = Configuration { _configDefaults :: ServerSettings -- ^ Default connection settings , _configServers :: (HashMap Text ServerSettings) -- ^ Host-specific settings - , _configPalette :: Palette + , _configPalette :: Palette -- ^ User-customized color palette , _configWindowNames :: Text -- ^ Names of windows, used when alt-jumping) , _configExtraHighlights :: HashSet Identifier -- ^ Extra highlight nicks/terms , _configNickPadding :: PaddingMode -- ^ Padding of nicks in messages @@ -137,16 +137,19 @@ -- | default instance instance Exception ConfigurationFailure +-- | The default client behavior for naming windows is to use the first two +-- rows of a QWERTY keyboard followed by the first two rows combined with +-- SHIFT. defaultWindowNames :: Text defaultWindowNames = "1234567890qwertyuiop!@#$%^&*()QWERTYUIOP" --- | Uses 'getAppUserDataDirectory' to find @.glirc/config@ +-- | Uses 'getAppUserDataDirectory' to find @~/.glirc/config@ getOldConfigPath :: IO FilePath getOldConfigPath = do dir <- getAppUserDataDirectory "glirc" return (dir "config") --- | Uses 'getXdgDirectory' 'XdgConfig' to find @.config/glirc/config@ +-- | Uses 'getXdgDirectory' 'XdgConfig' to find @~/.config/glirc/config@ getNewConfigPath :: IO FilePath getNewConfigPath = do dir <- getXdgDirectory XdgConfig "glirc" @@ -215,6 +218,8 @@ Right cfg -> resolvePaths path (cfg def) +-- | Generate a human-readable explanation of an error arising from +-- an attempt to load a configuration file. explainLoadError :: LoadError Position -> Text explainLoadError (LoadError pos path problem) = Text.concat [ positionText, " at ", pathText, ": ", problemText] @@ -327,6 +332,8 @@ amtSec = reqSection' "width" nonnegativeSpec "Field width" +-- | Parse either a single modifier key or a list of modifier keys: +-- @meta@, @alt@, @ctrl@ modifierSpec :: ValueSpecs [Modifier] modifierSpec = toList <$> oneOrNonemptySpec modifier1Spec where @@ -335,13 +342,22 @@ MAlt <$ atomSpec "alt" MCtrl <$ atomSpec "ctrl" +-- | Parse either @one-column@ or @two-column@ and return the corresponding +-- 'LayoutMode' value. layoutSpec :: ValueSpecs LayoutMode layoutSpec = OneColumn <$ atomSpec "one-column" TwoColumn <$ atomSpec "two-column" +-- | Parse a single key binding. This can be an action binding, command +-- binding, or an unbinding specification. keyBindingSpec :: ValueSpecs (KeyMap -> KeyMap) keyBindingSpec = actBindingSpec cmdBindingSpec unbindingSpec +-- | Parse a single action key binding. Action bindings are a map specifying +-- a binding using 'keySpec' and an action: +-- +-- > bind: "M-a" +-- > action: jump-to-activity actBindingSpec :: ValueSpecs (KeyMap -> KeyMap) actBindingSpec = sectionsSpec "action-binding" $ do ~(m,k) <- reqSection' "bind" keySpec diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -43,7 +43,6 @@ import Data.Foldable import Data.List import Data.Maybe -import Data.Monoid import Data.Ord import Data.Text (Text) import qualified Data.Text as Text @@ -419,8 +418,11 @@ doAction vty action st = let continue !out -- detect when chains of M-a are broken - | action == ActJumpToActivity = return (Just out) - | otherwise = return $! Just $! set clientActivityReturn (view clientFocus out) out + | action == ActJumpToActivity = + let upd Nothing = Just $! view clientFocus st + upd x = x + in return $! Just $! over clientActivityReturn upd out + | otherwise = return (Just out) changeEditor f = continue (over clientTextBox f st) changeContent f = changeEditor @@ -428,7 +430,7 @@ . set Edit.lastOperation Edit.OtherOperation mbChangeEditor f = - case clientTextBox f st of + case traverseOf clientTextBox f st of Nothing -> continue $! set clientBell True st Just st' -> continue st' in diff --git a/src/Client/EventLoop/Errors.hs b/src/Client/EventLoop/Errors.hs --- a/src/Client/EventLoop/Errors.hs +++ b/src/Client/EventLoop/Errors.hs @@ -16,9 +16,8 @@ import Control.Exception import Data.List.NonEmpty (NonEmpty(..)) -import Network.Socks5 import OpenSSL.Session -import Hookup +import Hookup (ConnectionFailure(..)) -- | Compute the message message text to be used for a connection error exceptionToLines :: @@ -45,9 +44,6 @@ | Just (ProtocolError e) <- fromException ex = ("TLS protocol error: " ++ e) :| [] - -- socks package errors - | Just err <- fromException ex = explainSocksError err :| [] - -- IOErrors, typically network package. | Just ioe <- fromException ex = explainIOError ioe :| [] @@ -61,9 +57,6 @@ explainHookupError :: ConnectionFailure -> NonEmpty String explainHookupError e = case e of - HostnameResolutionFailure ioe -> - ("Host not resolved: " ++ displayException ioe) :| [] - ConnectionFailure exs -> "Connect failed" :| map explainIOError exs @@ -73,16 +66,5 @@ LineTruncated -> "IRC message incomplete" :| [] - -explainSocksError :: SocksError -> String -explainSocksError ex = - case ex of - SocksErrorGeneralServerFailure -> "SOCKS: General server failure" - SocksErrorConnectionNotAllowedByRule -> "SOCKS: Connection not allowed by rule" - SocksErrorNetworkUnreachable -> "SOCKS: Network unreachable" - SocksErrorHostUnreachable -> "SOCKS: Host unreachable" - SocksErrorConnectionRefused -> "SOCKS: Connection refused" - SocksErrorTTLExpired -> "SOCKS: TTL Expired" - SocksErrorCommandNotSupported -> "SOCKS: Command not supported" - SocksErrorAddrTypeNotSupported -> "SOCKS: Address type not supported" - SocksErrorOther n -> "SOCKS: Unknown error " ++ show n + -- the remaining messages can be used as is and on one line + _ -> displayException e :| [] diff --git a/src/Client/Hook.hs b/src/Client/Hook.hs --- a/src/Client/Hook.hs +++ b/src/Client/Hook.hs @@ -23,7 +23,6 @@ ) where import Control.Lens -import Data.Semigroup import Data.Text import Irc.Message diff --git a/src/Client/Image/LineWrap.hs b/src/Client/Image/LineWrap.hs --- a/src/Client/Image/LineWrap.hs +++ b/src/Client/Image/LineWrap.hs @@ -16,7 +16,6 @@ ) where import Client.Image.PackedImage -import Data.Semigroup import qualified Graphics.Vty.Image as Vty import Graphics.Vty.Attributes import qualified Data.Text.Lazy as L diff --git a/src/Client/Image/Message.hs b/src/Client/Image/Message.hs --- a/src/Client/Image/Message.hs +++ b/src/Client/Image/Message.hs @@ -41,7 +41,6 @@ import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.List -import Data.Semigroup import Data.Text (Text) import qualified Data.Text as Text import Data.Time @@ -463,8 +462,13 @@ DetailedRender -> string attr (shows w " ") <> rawParamsImage NormalRender -> case code of - RPL_WHOISIDLE -> whoisIdleParamsImage - _ -> rawParamsImage + RPL_WHOISIDLE -> whoisIdleParamsImage + RPL_TOPIC -> topicParamsImage + RPL_TOPICWHOTIME -> topicWhoTimeParamsImage + RPL_CHANNEL_URL -> channelUrlParamsImage + RPL_CREATIONTIME -> creationTimeParamsImage + RPL_INVITING -> invitingParamsImage + _ -> rawParamsImage where rawParamsImage = separatedParams params' @@ -482,9 +486,38 @@ attr = withForeColor defAttr color + invitingParamsImage = + case params of + [_, user, _] -> text' defAttr user + _ -> rawParamsImage + + topicParamsImage = + case params of + [_, _, topic] -> text' defAttr topic + _ -> rawParamsImage + + topicWhoTimeParamsImage = + case params of + [_, _, who, time] -> + text' defAttr "set by " <> + text' defAttr who <> + text' defAttr " at " <> + string defAttr (prettyUnixTime (Text.unpack time)) + _ -> rawParamsImage + + channelUrlParamsImage = + case params of + [_, _, url] -> text' defAttr url + _ -> rawParamsImage + + creationTimeParamsImage = + case params of + [_, _, time, _] -> string defAttr (prettyUnixTime (Text.unpack time)) + _ -> rawParamsImage + whoisIdleParamsImage = - case params' of - [name, idle, signon, _txt] -> + case params of + [_, name, idle, signon, _txt] -> text' defAttr name <> text' defAttr " idle: " <> string defAttr (prettySeconds (Text.unpack idle)) <> diff --git a/src/Client/Image/MircFormatting.hs b/src/Client/Image/MircFormatting.hs --- a/src/Client/Image/MircFormatting.hs +++ b/src/Client/Image/MircFormatting.hs @@ -129,8 +129,8 @@ applyControlEffect '\^B' attr = Just $! toggleStyle bold attr applyControlEffect '\^V' attr = Just $! toggleStyle reverseVideo attr applyControlEffect '\^_' attr = Just $! toggleStyle underline attr +applyControlEffect '\^]' attr = Just $! toggleStyle italic attr applyControlEffect '\^O' _ = Just defAttr -applyControlEffect '\^]' attr = Just attr -- italic not supported applyControlEffect _ _ = Nothing toggleStyle :: Style -> Attr -> Attr diff --git a/src/Client/Image/PackedImage.hs b/src/Client/Image/PackedImage.hs --- a/src/Client/Image/PackedImage.hs +++ b/src/Client/Image/PackedImage.hs @@ -26,7 +26,6 @@ import Data.List (findIndex) import qualified Data.Text as S import qualified Data.Text.Lazy as L -import Data.Semigroup import Data.String import Graphics.Vty.Attributes import Graphics.Vty.Image ((<|>), wcswidth, wcwidth) diff --git a/src/Client/Image/StatusLine.hs b/src/Client/Image/StatusLine.hs --- a/src/Client/Image/StatusLine.hs +++ b/src/Client/Image/StatusLine.hs @@ -25,9 +25,9 @@ import Client.State.Network import Client.State.Window import Control.Lens +import Data.Foldable (for_) import qualified Data.Map.Strict as Map import Data.Maybe -import Data.Semigroup import Data.Text (Text) import qualified Data.Text as Text import Graphics.Vty.Attributes @@ -125,23 +125,34 @@ -- that the connection is being established or that a ping has been -- sent or long the previous ping round-trip was. latencyImage :: ClientState -> Image' -latencyImage st = - case views clientFocus focusNetwork st of - Nothing -> mempty - Just network -> - case preview (clientConnection network) st of - Nothing -> infoBubble (string (view palError pal) "offline") - Just cs -> - case view csPingStatus cs of - PingNever -> mempty - PingSent {} -> latency "ping sent" - PingLatency delta -> latency (showFFloat (Just 2) delta "s") - PingConnecting n _ -> - infoBubble (string (view palLatency pal) "connecting" <> - retryImage n) +latencyImage st = either id id $ + + do network <- -- no network -> no image + case views clientFocus focusNetwork st of + Nothing -> Left mempty + Just net -> Right net + + cs <- -- detect when offline + case preview (clientConnection network) st of + Nothing -> Left (infoBubble (string (view palError pal) "offline")) + Just cs -> Right cs + + -- render latency if one is stored + for_ (view csLatency cs) $ \latency -> + Left (latencyBubble (showFFloat (Just 2) (realToFrac latency :: Double) "s")) + + Right $ case view csPingStatus cs of + + PingSent {} -> latencyBubble "wait" + + PingConnecting n _ -> + infoBubble (string (view palLatency pal) "connecting" <> retryImage n) + + PingNone -> mempty -- just connected no ping sent yet + where - pal = clientPalette st - latency = infoBubble . string (view palLatency pal) + pal = clientPalette st + latencyBubble = infoBubble . string (view palLatency pal) retryImage n | n > 0 = ": " <> string (view palLabel pal) ("retry " ++ show n) diff --git a/src/Client/Image/Textbox.hs b/src/Client/Image/Textbox.hs --- a/src/Client/Image/Textbox.hs +++ b/src/Client/Image/Textbox.hs @@ -33,7 +33,6 @@ import qualified Data.HashSet as HashSet import Data.HashSet (HashSet) import Data.List -import Data.Semigroup import qualified Data.Text as Text import Graphics.Vty.Attributes import qualified Graphics.Vty.Image as Vty diff --git a/src/Client/Log.hs b/src/Client/Log.hs --- a/src/Client/Log.hs +++ b/src/Client/Log.hs @@ -15,7 +15,6 @@ import Client.Message import Control.Exception import Control.Lens hiding ((<.>)) -import Data.Monoid import Data.Time import Data.Text (Text) import qualified Data.Text as Text diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -159,7 +159,7 @@ data ClientState = ClientState { _clientWindows :: !(Map Focus Window) -- ^ client message buffers , _clientPrevFocus :: !Focus -- ^ previously focused buffer - , _clientActivityReturn :: !Focus -- ^ focus prior to jumping to activity + , _clientActivityReturn :: !(Maybe Focus) -- ^ focus prior to jumping to activity , _clientFocus :: !Focus -- ^ currently focused buffer , _clientSubfocus :: !Subfocus -- ^ current view mode , _clientExtraFocus :: ![Focus] -- ^ extra messages windows to view @@ -259,7 +259,7 @@ , _clientHeight = 25 , _clientEvents = events , _clientPrevFocus = Unfocused - , _clientActivityReturn = Unfocused + , _clientActivityReturn = Nothing , _clientFocus = Unfocused , _clientSubfocus = FocusMessages , _clientExtraFocus = [] @@ -391,11 +391,17 @@ Kick _ _ kicked _ | isMe kicked -> WLImportant | otherwise -> WLNormal Error{} -> WLImportant + + -- channel information + Reply RPL_TOPIC _ -> WLBoring + Reply RPL_INVITING _ -> WLBoring + + -- remaining replies go to network window Reply cmd _ -> case replyCodeType (replyCodeInfo cmd) of ErrorReply -> WLImportant _ -> WLNormal - _ -> WLBoring + _ -> WLBoring -- | Predicate for messages that should be ignored based on the @@ -848,15 +854,17 @@ -- Some events like errors or chat messages mentioning keywords are -- considered important and will be jumped to first. jumpToActivity :: ClientState -> ClientState -jumpToActivity st = changeFocus newFocus st +jumpToActivity st = + case mplus highPriority lowPriority of + Just (focus,_) -> changeFocus focus st + Nothing -> + case view clientActivityReturn st of + Just focus -> changeFocus focus st + Nothing -> st where windowList = views clientWindows Map.toAscList st highPriority = find (\x -> WLImportant == view winMention (snd x)) windowList lowPriority = find (\x -> view winUnread (snd x) > 0) windowList - newFocus = - case mplus highPriority lowPriority of - Just (focus,_) -> focus - Nothing -> view clientActivityReturn st -- | Jump the focus directly to a window based on its zero-based index. jumpFocus :: diff --git a/src/Client/State/Network.hs b/src/Client/State/Network.hs --- a/src/Client/State/Network.hs +++ b/src/Client/State/Network.hs @@ -41,6 +41,7 @@ , csNetwork , csNextPingTime , csPingStatus + , csLatency , csLastReceived , csMessageHooks , csAuthenticationState @@ -119,11 +120,14 @@ , _csUsers :: !(HashMap Identifier UserAndHost) -- ^ user and hostname for other nicks , _csModeCount :: !Int -- ^ maximum mode changes per MODE command , _csNetwork :: !Text -- ^ name of network connection - , _csNextPingTime :: !(Maybe UTCTime) -- ^ time for next ping event - , _csPingStatus :: !PingStatus -- ^ state of ping timer - , _csLastReceived :: !(Maybe UTCTime) -- ^ time of last message received , _csMessageHooks :: ![Text] -- ^ names of message hooks to apply to this connection , _csAuthenticationState :: !AuthenticateState + + -- Timing information + , _csNextPingTime :: !(Maybe UTCTime) -- ^ time for next ping event + , _csLatency :: !(Maybe NominalDiffTime) -- ^ latency calculated from previous pong + , _csPingStatus :: !PingStatus -- ^ state of ping timer + , _csLastReceived :: !(Maybe UTCTime) -- ^ time of last message received } deriving Show @@ -143,12 +147,17 @@ -- | Status of the ping timer data PingStatus - = PingSent !UTCTime -- ^ ping sent waiting for pong - | PingLatency !Double -- ^ latency in seconds for last ping - | PingNever -- ^ no ping sent + = PingSent !UTCTime -- ^ ping sent at given time, waiting for pong + | PingNone -- ^ not waiting for a pong | PingConnecting !Int !(Maybe UTCTime) -- ^ number of attempts, last known connection time deriving Show +-- | Timer-based events +data TimedAction + = TimedDisconnect -- ^ terminate the connection due to timeout + | TimedSendPing -- ^ transmit a ping to the server + | TimedForgetLatency -- ^ erase latency (when it is outdated) + deriving (Eq, Ord, Show) data Transaction = NoTransaction @@ -160,6 +169,7 @@ makeLenses ''NetworkState makePrisms ''Transaction makePrisms ''PingStatus +makePrisms ''TimedAction defaultChannelTypes :: String defaultChannelTypes = "#&" @@ -235,11 +245,12 @@ , _csModeCount = 3 , _csUsers = HashMap.empty , _csNetwork = network + , _csMessageHooks = view ssMessageHooks settings + , _csAuthenticationState = AS_None , _csPingStatus = ping + , _csLatency = Nothing , _csNextPingTime = Nothing , _csLastReceived = Nothing - , _csMessageHooks = view ssMessageHooks settings - , _csAuthenticationState = AS_None } @@ -324,7 +335,7 @@ = noReply . set csNick me . set csNextPingTime (Just $! addUTCTime 30 (zonedTimeToUTC msgWhen)) - . set csPingStatus PingNever + . set csPingStatus PingNone -- | Handle 'ERR_NICKNAMEINUSE' errors when connecting. doBadNick :: @@ -526,14 +537,13 @@ RPL_QUIETLIST -> True RPL_ENDOFQUIETLIST -> True RPL_CHANNELMODEIS -> True - RPL_TOPIC -> True + RPL_UMODEIS -> True + RPL_WHOREPLY -> True + RPL_ENDOFWHO -> True RPL_TOPICWHOTIME -> True RPL_CREATIONTIME -> True RPL_CHANNEL_URL -> True RPL_NOTOPIC -> True - RPL_UMODEIS -> True - RPL_WHOREPLY -> True - RPL_ENDOFWHO -> True _ -> False -- | Return 'True' for messages that should be hidden outside of @@ -623,8 +633,8 @@ supportedCaps :: NetworkState -> [Text] supportedCaps cs = - sasl ++ ["multi-prefix", "znc.in/batch", "znc.in/playback", - "znc.in/server-time-iso", "znc.in/self-message"] + sasl ++ ["multi-prefix", "batch", "znc.in/playback", + "server-time", "znc.in/self-message"] where ss = view csSettings cs sasl = ["sasl" | isJust (view ssSaslUsername ss) @@ -831,37 +841,53 @@ HashMap.insert nick (UserAndHost user host) users | otherwise = users --- | Timer-based events -data TimedAction - = TimedDisconnect -- ^ terminate the connection due to timeout - | TimedSendPing -- ^ transmit a ping to the server - deriving (Eq, Ord, Show) - -- | Compute the earliest timed action for a connection, if any nextTimedAction :: NetworkState -> Maybe (UTCTime, TimedAction) -nextTimedAction cs = +nextTimedAction ns = minimumOf (folded.folded) actions + where + actions = [nextPingAction ns, nextForgetAction ns] + +-- | Compute the timed action for forgetting the ping latency. +-- The client will wait for a multiple of the current latency +-- for the next pong response in order to reduce jitter in +-- the rendered latency when everything is fine. +nextForgetAction :: NetworkState -> Maybe (UTCTime, TimedAction) +nextForgetAction ns = + do sentAt <- preview (csPingStatus . _PingSent) ns + latency <- view csLatency ns + let delay = max 0.1 (3 * latency) -- wait at least 0.1s (ensure positive waits) + eventAt = addUTCTime delay sentAt + return (eventAt, TimedForgetLatency) + +-- | Compute the next action needed for the client ping logic. +nextPingAction :: NetworkState -> Maybe (UTCTime, TimedAction) +nextPingAction cs = do runAt <- view csNextPingTime cs return (runAt, action) where action = case view csPingStatus cs of - PingSent{} -> TimedDisconnect - PingLatency{} -> TimedSendPing - PingNever -> TimedSendPing + PingSent{} -> TimedDisconnect + PingNone -> TimedSendPing PingConnecting{} -> TimedSendPing doPong :: ZonedTime -> NetworkState -> NetworkState -doPong when cs = set csPingStatus (PingLatency delta) cs +doPong when cs = set csPingStatus PingNone + $ set csLatency (Just delta) cs where delta = case view csPingStatus cs of - PingSent sent -> realToFrac (diffUTCTime (zonedTimeToUTC when) sent) + PingSent sent -> diffUTCTime (zonedTimeToUTC when) sent _ -> 0 -- | Apply the given 'TimedAction' to a connection state. applyTimedAction :: TimedAction -> NetworkState -> IO NetworkState applyTimedAction action cs = + case action of + TimedForgetLatency -> + do return $! set csLatency Nothing cs + TimedDisconnect -> do abortConnection PingTimeout (view csSocket cs) return $! set csNextPingTime Nothing cs diff --git a/src/Client/View/ChannelInfo.hs b/src/Client/View/ChannelInfo.hs --- a/src/Client/View/ChannelInfo.hs +++ b/src/Client/View/ChannelInfo.hs @@ -25,7 +25,6 @@ import Client.State.Network import Control.Lens import Data.HashSet (HashSet) -import Data.Semigroup import Data.Text (Text) import Data.Time import Graphics.Vty.Attributes diff --git a/src/Client/View/IgnoreList.hs b/src/Client/View/IgnoreList.hs --- a/src/Client/View/IgnoreList.hs +++ b/src/Client/View/IgnoreList.hs @@ -19,7 +19,6 @@ import Irc.Identifier import Data.HashSet (HashSet) import Data.Foldable -import Data.Semigroup import Control.Lens -- | Render the lines used in a channel mask list. @@ -29,8 +28,7 @@ [Image'] ignoreListLines ignores pal = summaryLine ignores pal : - [ text' defAttr (cleanText (idText mask)) - | mask <- toList ignores ] + [ text' defAttr (cleanText (idText mask)) | mask <- toList ignores ] -- | Render a summary describing the number of ignore masks. diff --git a/src/Client/View/KeyMap.hs b/src/Client/View/KeyMap.hs --- a/src/Client/View/KeyMap.hs +++ b/src/Client/View/KeyMap.hs @@ -17,7 +17,6 @@ import Client.State import Control.Lens import Data.List -import Data.Semigroup import Data.Ord import Graphics.Vty.Attributes import Graphics.Vty.Input diff --git a/src/Client/View/MaskList.hs b/src/Client/View/MaskList.hs --- a/src/Client/View/MaskList.hs +++ b/src/Client/View/MaskList.hs @@ -24,7 +24,6 @@ import Data.List import Data.Ord import Data.Maybe -import Data.Semigroup import Data.Text (Text) import Data.Time import Graphics.Vty.Attributes diff --git a/src/Client/View/Messages.hs b/src/Client/View/Messages.hs --- a/src/Client/View/Messages.hs +++ b/src/Client/View/Messages.hs @@ -28,7 +28,6 @@ import Control.Lens import Control.Monad import Data.List -import Data.Semigroup import Irc.Identifier import Irc.Message import Irc.UserInfo diff --git a/src/Client/View/RtsStats.hs b/src/Client/View/RtsStats.hs --- a/src/Client/View/RtsStats.hs +++ b/src/Client/View/RtsStats.hs @@ -18,7 +18,6 @@ import Client.Image.PackedImage import Client.Image.Palette import Control.Lens -import Data.Semigroup import Graphics.Vty.Attributes import RtsStats diff --git a/src/Client/View/UrlSelection.hs b/src/Client/View/UrlSelection.hs --- a/src/Client/View/UrlSelection.hs +++ b/src/Client/View/UrlSelection.hs @@ -27,7 +27,6 @@ import Control.Lens import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet -import Data.Semigroup import Data.Text (Text) import Graphics.Vty.Attributes import Irc.Identifier diff --git a/src/Client/View/UserList.hs b/src/Client/View/UserList.hs --- a/src/Client/View/UserList.hs +++ b/src/Client/View/UserList.hs @@ -25,7 +25,6 @@ import Data.List import Data.Maybe import Data.Ord -import Data.Semigroup import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Lazy as LText diff --git a/src/Client/View/Windows.hs b/src/Client/View/Windows.hs --- a/src/Client/View/Windows.hs +++ b/src/Client/View/Windows.hs @@ -21,7 +21,6 @@ import Control.Lens import Data.List import qualified Data.Map as Map -import Data.Semigroup import Graphics.Vty.Attributes import Irc.Identifier