glirc 2.26 → 2.27

raw patch · 26 files changed

+250/−139 lines, 26 filesdep −socksdep ~basedep ~hookupdep ~irc-corePVP ok

version bump matches the API change (PVP)

Dependencies removed: socks

Dependency ranges changed: base, hookup, irc-core, vty

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• glirc.cabal +11/−12
• src/Client/Commands.hs +53/−15
• src/Client/Commands/Exec.hs +15/−10
• src/Client/Configuration.hs +19/−3
• src/Client/EventLoop.hs +6/−4
• src/Client/EventLoop/Errors.hs +3/−21
• src/Client/Hook.hs +0/−1
• src/Client/Image/LineWrap.hs +0/−1
• src/Client/Image/Message.hs +38/−5
• src/Client/Image/MircFormatting.hs +1/−1
• src/Client/Image/PackedImage.hs +0/−1
• src/Client/Image/StatusLine.hs +28/−17
• src/Client/Image/Textbox.hs +0/−1
• src/Client/Log.hs +0/−1
• src/Client/State.hs +16/−8
• src/Client/State/Network.hs +53/−27
• src/Client/View/ChannelInfo.hs +0/−1
• src/Client/View/IgnoreList.hs +1/−3
• src/Client/View/KeyMap.hs +0/−1
• src/Client/View/MaskList.hs +0/−1
• src/Client/View/Messages.hs +0/−1
• src/Client/View/RtsStats.hs +0/−1
• src/Client/View/UrlSelection.hs +0/−1
• src/Client/View/UserList.hs +0/−1
• src/Client/View/Windows.hs +0/−1

@@ -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

@@ -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

@@ -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 

@@ -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")

@@ -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

@@ -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

@@ -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 :| []

@@ -23,7 +23,6 @@   ) where  import Control.Lens-import Data.Semigroup import Data.Text  import Irc.Message

@@ -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

@@ -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)) <>

@@ -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

@@ -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)

@@ -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)

@@ -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

@@ -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

@@ -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 ::

@@ -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

@@ -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

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -18,7 +18,6 @@ import           Client.Image.PackedImage import           Client.Image.Palette import           Control.Lens-import           Data.Semigroup import           Graphics.Vty.Attributes import           RtsStats 

@@ -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

@@ -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

@@ -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