glirc 2.12 → 2.13

raw patch · 24 files changed

+408/−228 lines, 24 filesdep +socksdep ~vtyPVP ok

version bump matches the API change (PVP)

Dependencies added: socks

Dependency ranges changed: vty

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• Main.hs +0/−66
• README.md +8/−6
• exec/Main.hs +66/−0
• exec/linux_exported_symbols.txt +11/−0
• exec/macos_exported_symbols.txt +9/−0
• glirc.cabal +8/−7
• linux_exported_symbols.txt +0/−11
• macos_exported_symbols.txt +0/−9
• src/Client/CApi/Exports.hs +5/−0
• src/Client/Commands.hs +69/−18
• src/Client/Commands/Interpolation.hs +22/−7
• src/Client/Configuration.hs +23/−2
• src/Client/Configuration/ServerSettings.hs +7/−4
• src/Client/EventLoop.hs +29/−17
• src/Client/EventLoop/Errors.hs +46/−28
• src/Client/Image.hs +1/−1
• src/Client/Image/Arguments.hs +6/−11
• src/Client/Image/MircFormatting.hs +17/−3
• src/Client/Image/StatusLine.hs +2/−2
• src/Client/Image/Textbox.hs +28/−26
• src/Client/State.hs +11/−3
• src/Client/State/Network.hs +25/−6
• src/LensUtils.hs +7/−1

@@ -1,5 +1,13 @@ # Revision history for glirc2 +## 2.13++* Add disconnect expansion, support expansions in connect-cmds+* Add default expansion syntax `${var|default}`+* Add support for multiple nicknames to try on connect+* Add `ignores` section to configuration+* Add `url-opener` section to configuration and `/url` command+ ## 2.12  * Remove `tls-insecure` configuration option in favor of `tls: yes-insecure`

@@ -1,66 +0,0 @@-{-|-Module      : Main-Description : Entry-point of executable-Copyright   : (c) Eric Mertens, 2016-License     : ISC-Maintainer  : emertens@gmail.com--Entry point into glirc2. This module sets up VTY and launches the client.--}--module Main where--import Control.Concurrent-import Control.Lens-import Control.Monad-import Data.Text (Text)-import System.Exit-import System.IO--import Client.CommandArguments-import Client.Configuration-import Client.EventLoop-import Client.State-import Client.State.Focus---- | Main action for IRC client-main :: IO ()-main =-  do args <- getCommandArguments-     cfg  <- loadConfiguration' (view cmdArgConfigFile args)-     runInUnboundThread $-       withClientState cfg $-       clientStartExtensions >=>-       addInitialNetworks (view cmdArgInitialNetworks args) >=>-       eventLoop---- | Load configuration and handle errors along the way.-loadConfiguration' :: Maybe FilePath -> IO Configuration-loadConfiguration' path =-  do cfgRes <- loadConfiguration path-     case cfgRes of-       Right cfg -> return cfg-       Left (ConfigurationReadFailed e) ->-         report "Failed to open configuration:" e-       Left (ConfigurationParseFailed e) ->-         report "Failed to parse configuration:" e-       Left (ConfigurationMalformed e) ->-         report "Configuration malformed: " e-  where-    report problem msg =-      do hPutStrLn stderr problem-         hPutStrLn stderr msg-         exitFailure---- | Create connections for all the networks on the command line.--- Set the client focus to the first network listed.-addInitialNetworks ::-  [Text] {- networks -} ->-  ClientState           ->-  IO ClientState-addInitialNetworks networks st =-  case networks of-    []        -> return st-    network:_ ->-      do st' <- foldM (flip (addConnection 0 Nothing)) st networks-         return (set clientFocus (NetworkFocus network) st')

@@ -162,6 +162,8 @@ * `nick-padding` - nonnegative integer - Nicks are padded until they have the specified length * `extra-highlights` - list of text - Extra words/nicks to highlight * `extensions` - list of text - Filenames of extension to load+* `url-opener` - text - Command to execute with URL parameter for `/url` e.g. gnome-open on GNOME or open on macOS+* `ignores` - list of text - Initial list of nicknames to ignore  Settings --------@@ -169,7 +171,7 @@ * `name` - text - name of server entry, defaults to `hostname` * `hostname` - text - hostname used to connect and to specify the server * `port` - number - port number, defaults to 6667 without TLS and 6697 with TLS-* `nick` - text - nickname+* `nick` - text or list of text - nicknames to try in order * `username` - text - username * `realname` - text - realname / GECOS * `password` - text - server password@@ -243,11 +245,11 @@ * `/connect <name>` - Connect to the given server * `/disconnect` - Forcefully terminate connection to the current server * `/reconnect` - Reconnect to the current server-* `/reload` - Reload the previous configuration file (not retroactive!)-* `/reload <path>` - Load a new configuration file+* `/reload [path]` - Load a new configuration file (optional path) * `/windows` - List all open windows-* `/extension <extension name> <params>` - Send the given params to the named extension-* `/exec [-n network] [-c channel] <command> <arguments>` - Execute a command, If no network or channel are provided send output to client window, if network and channel are provided send output as messages, if network is provided send output as raw IRC messages.+* `/extension <extension name> <params...>` - Send the given params to the named extension+* `/exec [-n network] [-c channel] <command> <arguments...>` - Execute a command, If no network or channel are provided send output to client window, if network and channel are provided send output as messages, if network is provided send output as raw IRC messages.+* `/url [n]` - Execute url-opener on the nth URL in the current window (defaults to first)  Connection commands @@ -366,7 +368,7 @@ Variable names and integer indexes can be used when defining commands. Variables are specified with a leading `$`. For disambiguation a variable name can be surrounded by `{}`. `$channel` and `${channel}` are-equivalent.+equivalent. Default values can be provided following a pipe: `${var|default}`.  * `channel` - current channel * `network` - current network name

@@ -0,0 +1,66 @@+{-|+Module      : Main+Description : Entry-point of executable+Copyright   : (c) Eric Mertens, 2016+License     : ISC+Maintainer  : emertens@gmail.com++Entry point into glirc2. This module sets up VTY and launches the client.+-}++module Main where++import Control.Concurrent+import Control.Lens+import Control.Monad+import Data.Text (Text)+import System.Exit+import System.IO++import Client.CommandArguments+import Client.Configuration+import Client.EventLoop+import Client.State+import Client.State.Focus++-- | Main action for IRC client+main :: IO ()+main =+  do args <- getCommandArguments+     cfg  <- loadConfiguration' (view cmdArgConfigFile args)+     runInUnboundThread $+       withClientState cfg $+       clientStartExtensions >=>+       addInitialNetworks (view cmdArgInitialNetworks args) >=>+       eventLoop++-- | Load configuration and handle errors along the way.+loadConfiguration' :: Maybe FilePath -> IO Configuration+loadConfiguration' path =+  do cfgRes <- loadConfiguration path+     case cfgRes of+       Right cfg -> return cfg+       Left (ConfigurationReadFailed e) ->+         report "Failed to open configuration:" e+       Left (ConfigurationParseFailed e) ->+         report "Failed to parse configuration:" e+       Left (ConfigurationMalformed e) ->+         report "Configuration malformed: " e+  where+    report problem msg =+      do hPutStrLn stderr problem+         hPutStrLn stderr msg+         exitFailure++-- | Create connections for all the networks on the command line.+-- Set the client focus to the first network listed.+addInitialNetworks ::+  [Text] {- networks -} ->+  ClientState           ->+  IO ClientState+addInitialNetworks networks st =+  case networks of+    []        -> return st+    network:_ ->+      do st' <- foldM (flip (addConnection 0 Nothing)) st networks+         return (set clientFocus (NetworkFocus network) st')

@@ -0,0 +1,11 @@+{+glirc_send_message;+glirc_print;+glirc_identifier_cmp;+glirc_list_networks;+glirc_list_channels;+glirc_list_channel_users;+glirc_my_nick;+glirc_mark_seen;+glirc_clear_window;+};

@@ -0,0 +1,9 @@+_glirc_send_message+_glirc_print+_glirc_identifier_cmp+_glirc_list_networks+_glirc_list_channels+_glirc_list_channel_users+_glirc_my_nick+_glirc_mark_seen+_glirc_clear_window

@@ -1,5 +1,5 @@ name:                glirc-version:             2.12+version:             2.13 synopsis:            Console IRC client description:         Console IRC client license:             ISC@@ -10,8 +10,8 @@ category:            Network build-type:          Custom extra-source-files:  ChangeLog.md README.md-                     linux_exported_symbols.txt-                     macos_exported_symbols.txt+                     exec/linux_exported_symbols.txt+                     exec/macos_exported_symbols.txt cabal-version:       >=1.23 homepage:            https://github.com/glguy/irc-core bug-reports:         https://github.com/glguy/irc-core/issues@@ -30,13 +30,13 @@   main-is:             Main.hs   ghc-options:         -threaded -rtsopts -  hs-source-dirs:      .+  hs-source-dirs:      exec   default-language:    Haskell2010    if os(Linux)-    ld-options: -Wl,--dynamic-list=linux_exported_symbols.txt+    ld-options: -Wl,--dynamic-list=exec/linux_exported_symbols.txt   if os(Darwin)-    ld-options: -Wl,-exported_symbols_list,macos_exported_symbols.txt+    ld-options: -Wl,-exported_symbols_list,exec/macos_exported_symbols.txt    -- Constraints can be found on the library itself   build-depends:       base, glirc, lens, text@@ -112,6 +112,7 @@                        process              >=1.4.2  && <1.5,                        regex-tdfa           >=1.2    && <1.3,                        regex-tdfa-text      >=1.0    && <1.1,+                       socks                >=0.5.5  && <0.6,                        split                >=0.2    && <0.3,                        stm                  >=2.4    && <2.5,                        text                 >=1.2.2  && <1.3,@@ -121,7 +122,7 @@                        unix                 >=2.7    && <2.8,                        unordered-containers >=0.2.7  && <0.3,                        vector               >=0.11   && <0.12,-                       vty                  >=5.9.1  && <5.10,+                       vty                  >=5.10   && <5.11,                        x509                 >=1.6.3  && <1.7,                        x509-store           >=1.6.1  && <1.7,                        x509-system          >=1.6.3  && <1.7

@@ -1,11 +0,0 @@-{-glirc_send_message;-glirc_print;-glirc_identifier_cmp;-glirc_list_networks;-glirc_list_channels;-glirc_list_channel_users;-glirc_my_nick;-glirc_mark_seen;-glirc_clear_window;-};

@@ -1,9 +0,0 @@-_glirc_send_message-_glirc_print-_glirc_identifier_cmp-_glirc_list_networks-_glirc_list_channels-_glirc_list_channel_users-_glirc_my_nick-_glirc_mark_seen-_glirc_clear_window

@@ -111,6 +111,7 @@  ------------------------------------------------------------------------ +-- | Print a message or error to the client window type Glirc_print =   Ptr ()  {- ^ api token         -} ->   MessageCode {- ^ enum message_code -} ->@@ -158,6 +159,10 @@  ------------------------------------------------------------------------ +-- | Case insensitive comparison suitable for use on channels and nicknames.+-- Returns -1 if the first identifier is less than the second+-- Returns 0 if the first identifier is equal to the second+-- Returns 1 if the first identifier is greater than the second type Glirc_identifier_cmp =   CString {- ^ identifier 1     -} ->   CSize   {- ^ identifier 1 len -} ->

@@ -15,6 +15,7 @@   ( CommandResult(..)   , execute   , executeUserCommand+  , commandExpansion   , tabCompletion   -- * Commands   , Command(..)@@ -36,6 +37,7 @@ import           Client.State.Network import           Client.State.Window import           Control.Applicative+import           Control.Exception (displayException, try) import           Control.Lens import           Control.Monad import           Data.Char@@ -55,6 +57,9 @@ import           Irc.UserInfo import           Irc.Modes import           LensUtils+import           System.Process+import           Text.Read+import           Text.Regex.TDFA  -- | Possible results of running a command data CommandResult@@ -115,33 +120,27 @@ execute str st =   case str of     []          -> commandFailure st-    '/':command -> executeUserCommand command st+    '/':command -> executeUserCommand Nothing command st     msg         -> executeChat msg st  -- | Execute command provided by user, resolve aliases if necessary.-executeUserCommand :: String -> ClientState -> IO CommandResult-executeUserCommand command st =-  let key = Text.pack (takeWhile (/=' ') command) in+executeUserCommand :: Maybe Text -> String -> ClientState -> IO CommandResult+executeUserCommand discoTime command st = do+  let key = Text.takeWhile (/=' ') tcmd    case preview (clientConfig . configMacros . ix key) st of-    Nothing -> executeCommand Nothing command st+    Nothing     -> executeCommand Nothing command st     Just cmdExs ->-      case traverse (resolveExpansions expandVar expandInt) cmdExs of+      case traverse resolveMacro cmdExs of         Nothing   -> commandFailureMsg "Macro expansions failed" st         Just cmds -> process cmds st   where-    args = Text.words (Text.pack command)+    resolveMacro = resolveMacroExpansions (commandExpansion discoTime st) expandInt -    expandInt i = preview (ix (fromInteger i)) args+    tcmd = Text.pack command+    args = Text.words tcmd -    expandVar v =-      case v of-        "network" -> views clientFocus focusNetwork st-        "channel" -> previews (clientFocus . _ChannelFocus . _2) idText st-        "nick"    -> do net <- views clientFocus focusNetwork st-                        cs  <- preview (clientConnection net) st-                        return (views csNick idText cs)-        _         -> Nothing+    expandInt i = preview (ix (fromInteger i)) args      process [] st0 = commandSuccess st0     process (c:cs) st0 =@@ -151,6 +150,18 @@            CommandFailure st1 -> process cs st1 -- ?            CommandQuit st1    -> return (CommandQuit st1) +commandExpansion :: Maybe Text -> ClientState -> Text -> Maybe Text+commandExpansion discoTime st v =+  case v of+    "network" -> views clientFocus focusNetwork st+    "channel" -> previews (clientFocus . _ChannelFocus . _2) idText st+    "nick"    -> do net <- views clientFocus focusNetwork st+                    cs  <- preview (clientConnection net) st+                    return (views csNick idText cs)+    "disconnect" -> discoTime+    _         -> Nothing++ -- | 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.@@ -283,6 +294,10 @@     , Command (RemainingArg "arguments")     $ ClientCommand cmdExec simpleClientTab     )+  , ( ["url"]+    , Command (OptTokenArg "number" NoArg)+    $ ClientCommand cmdUrl noClientTab+    )    --   -- Network commands@@ -698,8 +713,12 @@     [timeStr]        | Just tod <- parse timeFormats timeStr ->           do now <- getZonedTime-             successZoned-               (set (zonedTimeLocalTime . localTimeTimeOfDay) tod now)+             let (nowTod,t) = (zonedTimeLocalTime . localTimeTimeOfDay <<.~ tod) now+                 yesterday = over (zonedTimeLocalTime . localTimeDay) (addDays (-1))+                 fixDay+                   | tod <= nowTod = id+                   | otherwise     = yesterday+             successZoned (fixDay t)      -- explicit date and time     [dateStr,timeStr]@@ -1158,3 +1177,35 @@     , _msgBody    = NormalBody m     , _msgNetwork = ""     } ste++cmdUrl :: ClientCommand (Maybe (String, ()))+cmdUrl st mbArg =+  case view (clientConfig . configUrlOpener) st of+    Nothing -> commandFailureMsg "/url requires url-opener to be configured" st+    Just opener ->+      case mbArg of+        Nothing -> doUrlOpen opener 0+        Just (arg,_) ->+          case readMaybe arg of+            Just n | n > 0 -> doUrlOpen opener (n-1)+            _ -> commandFailureMsg "/url expected positive integer argument" st+  where+    focus = view clientFocus st++    urlMatches :: Text -> [Text]+    urlMatches = getAllTextMatches . match urlPattern++    urls = toListOf ( clientWindows . ix focus . winMessages . folded . wlText+                    . folding urlMatches) st++    doUrlOpen opener n =+      case preview (ix n) urls of+        Just url -> openUrl opener (Text.unpack url) st+        Nothing  -> commandFailureMsg "/url couldn't find requested URL" st++openUrl :: FilePath -> String -> ClientState -> IO CommandResult+openUrl opener url st =+  do res <- try (callProcess opener [url])+     case res of+       Left e  -> commandFailureMsg (Text.pack (displayException (e :: IOError))) st+       Right{} -> commandSuccess st

@@ -14,7 +14,7 @@ module Client.Commands.Interpolation   ( ExpansionChunk(..)   , parseExpansion-  , resolveExpansions+  , resolveMacroExpansions   ) where  import           Control.Applicative@@ -25,9 +25,14 @@  -- | Parsed chunk of an expandable command data ExpansionChunk-  = LiteralChunk Text    -- ^ regular text-  | VariableChunk Text   -- ^ inline variable @$x@ or @${x y}@-  | IntegerChunk Integer -- ^ inline variable @$1@ or @${1}@+  -- | regular text+  = LiteralChunk Text+  -- | inline variable @$x@ or @${x y}@+  | VariableChunk Text+  -- | inline variable @$1@ or @${1}@+  | IntegerChunk Integer+  -- | bracketed variable with default @${x|lit}@+  | DefaultChunk ExpansionChunk Text   deriving Show  parseExpansion :: Text -> Maybe [ExpansionChunk]@@ -41,21 +46,31 @@   choice     [ LiteralChunk     <$> P.takeWhile1 (/= '$')     , LiteralChunk "$" <$  P.string "$$"-    , string "${" *> parseVariable <* char '}'+    , string "${" *> parseDefaulted <* char '}'     , char '$' *> parseVariable     ] +parseDefaulted :: Parser ExpansionChunk+parseDefaulted =+  construct+    <$> parseVariable+    <*> optional (char '|' *> P.takeWhile1 (/= '}'))+ where+ construct ch Nothing  = ch+ construct ch (Just l) = DefaultChunk ch l+ parseVariable :: Parser ExpansionChunk parseVariable = IntegerChunk  <$> P.decimal             <|> VariableChunk <$> P.takeWhile1 isAlpha -resolveExpansions ::+resolveMacroExpansions ::   (Text    -> Maybe Text) {- ^ variable resolution       -} ->   (Integer -> Maybe Text) {- ^ argument index resolution -} ->   [ExpansionChunk]                                          ->   Maybe Text-resolveExpansions var arg xs = Text.concat <$> traverse resolve1 xs+resolveMacroExpansions var arg xs = Text.concat <$> traverse resolve1 xs   where     resolve1 (LiteralChunk lit) = Just lit     resolve1 (VariableChunk v)  = var v     resolve1 (IntegerChunk i)   = arg i+    resolve1 (DefaultChunk p d) = resolve1 p <|> Just d

@@ -27,6 +27,8 @@   , configMacros   , configExtensions   , configExtraHighlights+  , configUrlOpener+  , configIgnores    -- * Loading configuration   , loadConfiguration@@ -49,6 +51,8 @@ import qualified Data.HashMap.Strict as HashMap import           Data.HashSet (HashSet) import qualified Data.HashSet as HashSet+import           Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty import           Data.Maybe import           Data.Text (Text) import qualified Data.Text as Text@@ -73,6 +77,8 @@         -- ^ manually specified configuration path, used for reloading   , _configMacros           :: HashMap Text [[ExpansionChunk]] -- ^ command macros   , _configExtensions       :: [FilePath] -- ^ paths to shared library+  , _configUrlOpener        :: Maybe FilePath -- ^ paths to url opening executable+  , _configIgnores          :: HashSet Identifier -- ^ initial ignore list   }   deriving Show @@ -185,10 +191,16 @@      _configExtensions <- fromMaybe []                     <$> sectionOptWith (parseList parseString) "extensions" +     _configUrlOpener <- sectionOptWith parseString "url-opener"+      _configExtraHighlights <- maybe HashSet.empty HashSet.fromList                     <$> sectionOptWith (parseList parseIdentifier) "extra-highlights"       _configNickPadding <- sectionOpt "nick-padding"++     _configIgnores <- maybe HashSet.empty HashSet.fromList+                    <$> sectionOptWith (parseList parseIdentifier) "ignores"+      for_ _configNickPadding (\padding ->        when (padding < 0)             (liftConfigParser $@@ -248,7 +260,7 @@ parseServerSetting :: ServerSettings -> Text -> Value -> ConfigParser ServerSettings parseServerSetting ss k v =   case k of-    "nick"                -> setField       ssNick+    "nick"                -> setFieldWith   ssNicks parseNicks     "username"            -> setField       ssUser     "realname"            -> setField       ssReal     "userinfo"            -> setField       ssUserInfo@@ -261,7 +273,7 @@     "tls-client-cert"     -> setFieldWithMb ssTlsClientCert parseString     "tls-client-key"      -> setFieldWithMb ssTlsClientKey  parseString     "server-certificates" -> setFieldWith   ssServerCerts   (parseList parseString)-    "connect-cmds"        -> setField       ssConnectCmds+    "connect-cmds"        -> setFieldWith   ssConnectCmds   (parseList parseMacroCommand)     "socks-host"          -> setFieldWithMb ssSocksHost     parseString     "socks-port"          -> setFieldWith   ssSocksPort     parseNum     "chanserv-channels"   -> setFieldWith   ssChanservChannels (parseList parseIdentifier)@@ -281,6 +293,15 @@     setFieldWithMb l p =       do x <- p v          return $! set l (Just x) ss++parseNicks :: Value -> ConfigParser (NonEmpty Text)+parseNicks (Text nick) = return (nick NonEmpty.:| [])+parseNicks (List xs) =+  do xs' <- parseList parseConfig (List xs)+     case xs' of+       [] -> failure "empty list"+       y:ys -> return (y NonEmpty.:| ys)+parseNicks _ = failure "expected text or list of text"  parseUseTls :: Value -> ConfigParser UseTls parseUseTls (Atom "yes")          = return UseTls

@@ -16,7 +16,7 @@   (   -- * Server settings type     ServerSettings(..)-  , ssNick+  , ssNicks   , ssUser   , ssReal   , ssUserInfo@@ -46,7 +46,10 @@    ) where +import           Client.Commands.Interpolation import           Control.Lens+import           Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty import           Data.Maybe (fromMaybe) import           Data.Text (Text) import qualified Data.Text as Text@@ -56,7 +59,7 @@  -- | Static server-level settings data ServerSettings = ServerSettings-  { _ssNick             :: !Text -- ^ connection nickname+  { _ssNicks            :: !(NonEmpty Text) -- ^ connection nicknames   , _ssUser             :: !Text -- ^ connection username   , _ssReal             :: !Text -- ^ connection realname / GECOS   , _ssUserInfo         :: !Text -- ^ CTCP userinfo@@ -68,7 +71,7 @@   , _ssTls              :: !UseTls -- ^ use TLS to connect   , _ssTlsClientCert    :: !(Maybe FilePath) -- ^ path to client TLS certificate   , _ssTlsClientKey     :: !(Maybe FilePath) -- ^ path to client TLS key-  , _ssConnectCmds      :: ![Text] -- ^ raw IRC messages to transmit upon successful connection+  , _ssConnectCmds      :: ![[ExpansionChunk]] -- ^ commands to execute upon successful connection   , _ssSocksHost        :: !(Maybe HostName) -- ^ hostname of SOCKS proxy   , _ssSocksPort        :: !PortNumber -- ^ port of SOCKS proxy   , _ssServerCerts      :: ![FilePath] -- ^ additional CA certificates for validating server@@ -97,7 +100,7 @@   do env  <- getEnvironment      let username = Text.pack (fromMaybe "guest" (lookup "USER" env))      return ServerSettings-       { _ssNick          = username+       { _ssNicks         = username NonEmpty.:| []        , _ssUser          = username        , _ssReal          = username        , _ssUserInfo      = username

@@ -17,6 +17,7 @@  import           Client.CApi import           Client.Commands+import           Client.Commands.Interpolation import           Client.Configuration import           Client.Configuration.ServerSettings import           Client.EventLoop.Errors (exceptionToLines)@@ -146,12 +147,12 @@   do let (cs,st1) = removeNetwork networkId st          st2 = foldl' (flip recordNetworkMessage) st1 msgs -         msgs = [ ClientMessage+         msgs = exceptionToLines ex <&> \e ->+                ClientMessage                  { _msgTime    = time                  , _msgNetwork = view csNetwork cs                  , _msgBody    = ErrorBody (Text.pack e)                  }-                | e <- exceptionToLines ex ]           shouldReconnect =            case view csPingStatus cs of@@ -168,16 +169,13 @@            reconnect = do-           (delaySecs, mbDisconnectTime)+           (attempts, mbDisconnectTime)               <- case view csPingStatus cs of-                   PingSent tm -> pure (1, Just (addUTCTime (-60) tm))-                   PingConnecting n tm -> pure (n+1, tm)-                   _ | Just tm <- view csNextPingTime cs ->-                         pure (1, Just (addUTCTime (-60) tm))-                     | otherwise ->-                        do now <- getCurrentTime-                           pure (1, Just now)-           addConnection delaySecs mbDisconnectTime (view csNetwork cs) st2+                   PingConnecting n tm                   -> pure (n+1, tm)+                   _ | Just tm <- view csLastReceived cs -> pure (1, Just tm)+                     | otherwise -> do now <- getCurrentTime+                                       pure (1, Just now)+           addConnection attempts mbDisconnectTime (view csNetwork cs) st2           nextAction            | shouldReconnect = reconnect@@ -245,6 +243,9 @@                                          }                     -- record messages *before* applying the changes+                   --+                   -- Note: it's important to do this before 'clientResponse'+                   -- as $nick won't be set until 'doWelcome' happens.                    (replies, st2) = applyMessageToClientState time irc networkId cs recSt  -- | Client-level responses to specific IRC messages.@@ -264,14 +265,25 @@   ZonedTime       {- ^ now             -} ->   NetworkState    {- ^ current network -} ->   ClientState                             ->-  Text            {- ^ command         -} ->+  [ExpansionChunk]{- ^ command         -} ->   IO ClientState processConnectCmd now cs st0 cmdTxt =-  do res <- executeUserCommand (Text.unpack cmdTxt) st0-     return $! case res of-       CommandFailure st -> reportConnectCmdError now cs cmdTxt st-       CommandSuccess st -> st-       CommandQuit    st -> st -- not supported+  do dc <- forM disco $ \t ->+             Text.pack . formatTime defaultTimeLocale "%H:%M:%S"+               <$> utcToLocalZonedTime t+     let failureCase = reportConnectCmdError now cs+     case resolveMacroExpansions (commandExpansion dc st0) (const Nothing) cmdTxt of+       Nothing -> return $! failureCase "Unable to expand connect command" st0+       Just cmdTxt' ->+         do res <- executeUserCommand dc (Text.unpack cmdTxt') st0+            return $! case res of+              CommandFailure st -> failureCase cmdTxt' st+              CommandSuccess st -> st+              CommandQuit    st -> st -- not supported+ where+ disco = case view csPingStatus cs of+   PingConnecting _ tm -> tm+   _ -> Nothing   reportConnectCmdError ::

@@ -16,33 +16,35 @@  import           Control.Exception import           Data.Char+import           Data.List.NonEmpty (NonEmpty(..)) import           Network.Connection import           Network.TLS+import           Network.Socks5  -- | Compute the message message text to be used for a connection error exceptionToLines ::-  SomeException {- ^ network error -} ->-  [String]      {- ^ client lines  -}+  SomeException   {- ^ network error -} ->+  NonEmpty String {- ^ client lines  -} exceptionToLines   = indentMessages-  . map cleanLine+  . fmap cleanLine   . exceptionToLines' -indentMessages :: [String] -> [String]-indentMessages []    = ["PANIC: No error message generated"]-indentMessages (x:xs) = x : map ("⋯ "++) xs+indentMessages :: NonEmpty String -> NonEmpty String+indentMessages (x :| xs) = x :| map ("⋯ "++) xs  cleanLine :: String -> String-cleanLine = map $ \x ->-  case x of-    '\n' -> '⏎'-    '\t' -> ' '-    _ | isControl x -> '�'-      | otherwise   -> x+cleanLine = map clean1+  where+    clean1 x+      | x < '\x20'  = chr (0x2400 + ord x)+      | x == '\DEL' = '␡'+      | isControl x = '�'+      | otherwise   = x  exceptionToLines' ::-  SomeException {- ^ network error -} ->-  [String]      {- ^ client lines  -}+  SomeException   {- ^ network error -} ->+  NonEmpty String {- ^ client lines  -} exceptionToLines' ex    -- TLS package errors@@ -50,39 +52,42 @@    -- connection package errors   | Just (HostNotResolved str) <- fromException ex =-      ["Host not resolved: " ++ str]+      ("Host not resolved: " ++ str) :| []    | Just (HostCannotConnect str exs) <- fromException ex =-      ("Host cannot connect: " ++ str)-    : concatMap explainIOError exs+      ("Host cannot connect: " ++ str) :| map explainIOError exs +  | Just LineTooLong <- fromException ex = "Server IRC message too long" :| []++  -- socks package errors+  | Just err <- fromException ex = explainSocksError err :| []+   -- IOErrors, typically network package.   | Just ioe <- fromException ex =-     explainIOError ioe+     explainIOError ioe :| []    -- Anything else including glirc's errors (which use displayException)-  | otherwise = [displayException ex]+  | otherwise = displayException ex :| [] -explainIOError :: IOError -> [String]-explainIOError ioe =-  ["IO error: " ++ displayException ioe]+explainIOError :: IOError -> String+explainIOError ioe = "IO error: " ++ displayException ioe -explainTLSException :: TLSException -> [String]+explainTLSException :: TLSException -> NonEmpty String explainTLSException ex =   case ex of     ConnectionNotEstablished ->-      ["Attempt to use connection out of order"]+      "Attempt to use connection out of order" :| []     Terminated _ _ tlsError ->         "Connection closed due to early-termination in TLS layer"-      : explainTLSError tlsError+      :| explainTLSError tlsError     HandshakeFailed (Error_Packet_Parsing str) ->-      [ "Connection closed due to handshake failure in TLS layer"-      , "Packet parse error: " ++ str+        "Connection closed due to handshake failure in TLS layer" :|+      [ "Packet parse error: " ++ str       , "Please verify you're using a TLS enabled port"       ]     HandshakeFailed tlsError ->         "Connection closed due to handshake failure in TLS layer"-      : explainTLSError tlsError+      :| explainTLSError tlsError  explainTLSError :: TLSError -> [String] explainTLSError ex =@@ -96,3 +101,16 @@     Error_Packet_unexpected msg expect -> ("Packet unexpected: " ++ msg)                                         : [ expect | not (null expect) ]     Error_Packet_Parsing str       -> ["Packet parse error: " ++ str]++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

@@ -37,7 +37,7 @@     where       (pos, img, st') = clientImage st       pic = Picture-              { picCursor     = Cursor pos (view clientHeight st - 1)+              { picCursor     = AbsoluteCursor pos (view clientHeight st - 1)               , picBackground = ClearBackground               , picLayers     = [img]               }

@@ -9,30 +9,25 @@  This module provides image rendering for the textbox in the context of command argument processing.+ -}  module Client.Image.Arguments   ( argumentsImage-  , plainText   ) where  import           Client.Commands.Arguments import           Client.Image.MircFormatting import           Client.Image.Palette import           Control.Lens-import           Data.Char import qualified Data.Text as Text import           Graphics.Vty.Image -plainText :: String -> Image-plainText "" = emptyImage-plainText xs =-  case break isControl xs of-    (first, ""       ) -> string defAttr first-    (first, cntl:rest) -> string defAttr first <|>-                          controlImage cntl <|>-                          plainText rest-+-- | Parse command arguments against a given 'ArgumentSpec'.+-- The given text will be rendered and then any missing arguments+-- will be indicated by extra placeholder values appended onto the+-- image. Parameters are rendered with 'plainText' except for+-- the case of 'RemainingArg' which supports WYSIWYG. argumentsImage :: Palette -> ArgumentSpec a -> String -> Image argumentsImage pal spec xs   | all (==' ') xs = placeholders

@@ -13,6 +13,7 @@ module Client.Image.MircFormatting   ( parseIrcText   , parseIrcTextExplicit+  , plainText   , controlImage   ) where @@ -23,7 +24,7 @@ import           Data.Char import           Data.Maybe import           Data.Text (Text)-import           Graphics.Vty hiding ((<|>))+import           Graphics.Vty.Image hiding ((<|>)) import qualified Graphics.Vty as Vty  data FormatState = FormatState@@ -64,8 +65,8 @@ parseIrcTextExplicit = parseIrcText' True  parseIrcText' :: Bool -> Text -> Image-parseIrcText' explicit = either (Vty.string defAttr) id-                      . parseOnly (pIrcLine explicit defaultFormatState)+parseIrcText' explicit = either plainText id+                       . parseOnly (pIrcLine explicit defaultFormatState)  data Segment = TextSegment Text | ControlSegment Char @@ -157,3 +158,16 @@     controlName c       | c < '\128' = chr (0x40 `xor` ord c)       | otherwise  = '!'++-- | Render a 'String' with default attributes and replacing all of the+-- control characters with reverse-video letters corresponding to caret+-- notation.+plainText :: String -> Image+plainText "" = emptyImage+plainText xs =+  case break isControl xs of+    (first, ""       ) -> Vty.string defAttr first+    (first, cntl:rest) -> Vty.string defAttr first Vty.<|>+                          controlImage cntl Vty.<|>+                          plainText rest+

@@ -29,6 +29,7 @@ import           Irc.Identifier (Identifier, idText) import           Numeric +-- | Renders the status line between messages and the textbox. statusLineImage :: ClientState -> Image statusLineImage st   = content <|> charFill defAttr '─' fillSize 1@@ -69,8 +70,7 @@       where         retryImage           | n > 0 = string defAttr ": " <|>-                    string (view palLabel pal)-                       (shows n (if n == 1 then "retry" else "retries"))+                    string (view palLabel pal) ("retry " ++ show n)           | otherwise = emptyImage   | otherwise = emptyImage   where

@@ -11,7 +11,9 @@  -} -module Client.Image.Textbox where+module Client.Image.Textbox+  ( textboxImage+  ) where  import           Client.Configuration import           Client.Commands@@ -27,7 +29,10 @@ import qualified Data.Text as Text import           Graphics.Vty.Image -textboxImage :: ClientState -> (Int, Image)+-- | Compute the UI image for the text input box. This computes+-- the logical cursor position on the screen to compensate for+-- VTY's cursor placement behavior.+textboxImage :: ClientState -> (Int, Image) -- ^ cursor column, image textboxImage st   = (pos, croppedImage)   where@@ -35,13 +40,13 @@   (txt, content) =      views (clientTextBox . Edit.content) (renderContent pal) st -  pos = computeCharWidth (width-1) txt+  pos = min (width-1) leftOfCurWidth    pal = view (clientConfig . configPalette) st    lineImage = beginning <|> content <|> ending -  leftOfCurWidth = myWcswidth txt+  leftOfCurWidth = myWcswidth ('^':txt)    croppedImage     | leftOfCurWidth < width = lineImage@@ -51,40 +56,31 @@   beginning = char attr '^'   ending    = char attr '$' -renderContent :: Palette -> Edit.Content -> (String, Image)+-- | Renders the whole, uncropped text box as well as the 'String'+-- corresponding to the rendered image which can be used for computing+-- the logical cursor position of the cropped version of the text box.+renderContent ::+  Palette         {- ^ palette                               -} ->+  Edit.Content    {- ^ content                               -} ->+  (String, Image) {- ^ plain text rendering, image rendering -} renderContent pal c = (txt, wholeImg)   where   as  = reverse (view Edit.above c)   bs  = view Edit.below c   cur = view Edit.line c +  curTxt  = view Edit.text cur   leftCur = take (view Edit.pos cur) (view Edit.text cur) -  -- ["one","two"] "three" --> "^two one three"-  txt = '^' : foldl (\acc x -> x ++ ' ' : acc) leftCur as+  -- ["one","two"] "three" --> "two one three"+  txt = foldl (\acc x -> x ++ ' ' : acc) leftCur as    wholeImg = horizCat            $ intersperse (plainText "\n")-           $ map (parseIrcTextExplicit . Text.pack) as-          ++ renderLine pal (view Edit.text cur)-           : map (parseIrcTextExplicit . Text.pack) bs+           $ map renderOtherLine as+          ++ renderLine pal curTxt+           : map renderOtherLine bs --- | Compute the number of code-points that will be visible--- when the given string is truncated to fit in the given--- number of terminal columns.-computeCharWidth ::-  Int    {- ^ rendered width           -} ->-  String {- ^ input string             -} ->-  Int    {- ^ codepoints that will fit -}-computeCharWidth = go 0-  where-    go !acc _ [] = acc-    go acc 0 _ = acc-    go acc w (x:xs)-      | z > w = acc + w -- didn't fit, will be filled in-      | otherwise = go (acc+1) (w-z) xs-      where-        z = myWcwidth x  -- | Version of 'wcwidth' that accounts for how control characters are -- rendered@@ -99,6 +95,12 @@ myWcswidth = sum . map myWcwidth  +-- | Render an unfocused line+renderOtherLine :: String -> Image+renderOtherLine = parseIrcTextExplicit . Text.pack++-- | Render the active text box line using command highlighting and+-- placeholders, and WYSIWYG mIRC formatting control characters. renderLine :: Palette -> String -> Image  renderLine pal ('/':xs)

@@ -40,6 +40,8 @@    -- * Client operations   , clientMatcher+  , urlPattern+   , consumeInput   , currentCompletionList   , ircIgnorable@@ -198,7 +200,7 @@      k ClientState         { _clientWindows           = _Empty # ()         , _clientNetworkMap        = _Empty # ()-        , _clientIgnores           = _Empty # ()+        , _clientIgnores           = view configIgnores cfg         , _clientConnections       = _Empty # ()         , _clientTextBox           = Edit.defaultEditBox         , _clientWidth             = width@@ -482,6 +484,7 @@   case break (==' ') (clientFirstLine st) of     ("/grep" ,_:reStr) -> go True  reStr     ("/grepi",_:reStr) -> go False reStr+    ("/url"  ,_      ) -> match urlPattern     _                  -> const True   where     go sensitive reStr =@@ -489,6 +492,10 @@         Left{}  -> const True         Right r -> match r :: Text -> Bool +urlPattern :: Regex+urlPattern = makeRegex+  ("https?://([[:alnum:]-]+\\.)*([[:alnum:]-]+)(:[[:digit:]]+)?(/[^[:space:]]*)"::String)+ -- | Remove a network connection and unlink it from the network map. -- This operation assumes that the networkconnection exists and should -- only be applied once per connection.@@ -507,7 +514,7 @@  -- | Start a new connection. The delay is used for reconnections. addConnection ::-  Int           {- ^ delay in seconds         -} ->+  Int           {- ^ attempts                 -} ->   Maybe UTCTime {- ^ optional disconnect time -} ->   Text          {- ^ network name             -} ->   ClientState ->@@ -522,7 +529,8 @@                   $ preview (clientConfig . configServers . ix network) st       let (i,st') = st & clientNextConnectionId <+~ 1-         delay = 15 * attempts+         -- don't bother delaying on the first reconnect+         delay = 15 * max 0 (attempts - 1)      c <- createConnection             delay             i

@@ -39,6 +39,7 @@   , csNetwork   , csNextPingTime   , csPingStatus+  , csLastReceived   , csMessageHooks    -- * User information@@ -76,6 +77,7 @@ import           Data.Bits import           Data.Foldable import           Data.List+import qualified Data.List.NonEmpty as NonEmpty import           Data.Maybe import           Data.Text (Text) import qualified Data.Text as Text@@ -109,6 +111,7 @@   , _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   }   deriving Show@@ -124,9 +127,7 @@   = PingSent    !UTCTime -- ^ ping sent waiting for pong   | PingLatency !Double -- ^ latency in seconds for last ping   | PingNever -- ^ no ping sent-  | PingConnecting-      !Int -- ^ number of attempts-      !(Maybe UTCTime) -- ^ last known connection time+  | PingConnecting !Int !(Maybe UTCTime) -- ^ number of attempts, last known connection time   deriving Show  data Transaction@@ -193,7 +194,7 @@   NetworkState newNetworkState networkId network settings sock ping = NetworkState   { _csNetworkId    = networkId-  , _csUserInfo     = UserInfo (mkId (view ssNick settings)) "" ""+  , _csUserInfo     = UserInfo "*" "" ""   , _csChannels     = HashMap.empty   , _csSocket       = sock   , _csChannelTypes = "#&"@@ -207,6 +208,7 @@   , _csNetwork      = network   , _csPingStatus   = ping   , _csNextPingTime = Nothing+  , _csLastReceived = Nothing   , _csMessageHooks = view ssMessageHooks settings   } @@ -222,7 +224,12 @@ overChannels = overStrict (csChannels . traverse)  applyMessage :: ZonedTime -> IrcMsg -> NetworkState -> ([RawIrcMsg], NetworkState)-applyMessage msgWhen msg cs =+applyMessage msgWhen msg cs+  = applyMessage' msgWhen msg+  $ set csLastReceived (Just $! zonedTimeToUTC msgWhen) cs++applyMessage' :: ZonedTime -> IrcMsg -> NetworkState -> ([RawIrcMsg], NetworkState)+applyMessage' msgWhen msg cs =   case msg of     Ping args -> ([ircPong args], cs)     Pong _    -> noReply $ doPong msgWhen cs@@ -257,6 +264,8 @@     Reply RPL_WELCOME (me:_) -> doWelcome msgWhen (mkId me) cs     Reply RPL_SASLSUCCESS _ -> ([ircCapEnd], cs)     Reply RPL_SASLFAIL _ -> ([ircCapEnd], cs)+    Reply ERR_NICKNAMEINUSE (_:badnick:_)+      | PingConnecting{} <- view csPingStatus cs -> doBadNick badnick cs     Reply code args        -> noReply (doRpl code msgWhen args cs)     Cap cmd params         -> doCap cmd params cs     Authenticate param     -> doAuthenticate param cs@@ -278,6 +287,16 @@   . set csNextPingTime (Just $! addUTCTime 30 (zonedTimeToUTC msgWhen))   . set csPingStatus PingNever +-- | Handle 'ERR_NICKNAMEINUSE' errors when connecting.+doBadNick ::+  Text {- ^ bad nickname -} ->+  NetworkState ->+  ([RawIrcMsg], NetworkState) {- ^ replies, updated state -}+doBadNick badNick cs =+  case NonEmpty.dropWhile (badNick/=) (view (csSettings . ssNicks) cs) of+    _:next:_ -> ([ircNick (mkId next)], cs)+    _        -> ([], cs)+ doTopic :: ZonedTime -> UserInfo -> Identifier -> Text -> NetworkState -> NetworkState doTopic when user chan topic =   overChannel chan (setTopic topic . set chanTopicProvenance (Just $! prov))@@ -605,7 +624,7 @@ initialMessages cs    = [ ircCapLs ]   ++ [ ircPass pass | Just pass <- [view ssPassword ss]]-  ++ [ ircNick (view csNick cs)+  ++ [ ircNick (mkId (views ssNicks NonEmpty.head ss))      , ircUser (view ssUser ss) False True (view ssReal ss)      ]   where

@@ -17,6 +17,7 @@   -- * time lenses   , zonedTimeLocalTime   , localTimeTimeOfDay+  , localTimeDay   ) where  import           Control.Lens@@ -40,10 +41,15 @@  -- | 'Lens' to the 'LocalTime' component of a 'ZonedTime' zonedTimeLocalTime :: Lens' ZonedTime LocalTime-zonedTimeLocalTime f (ZonedTime t z) = f t <&> \t' -> ZonedTime t' z+zonedTimeLocalTime f (ZonedTime t z) = (ZonedTime ?? z) <$> f t {-# INLINE zonedTimeLocalTime #-}  -- | 'Lens' to the 'TimeOfDay component of a 'LocalTime'. localTimeTimeOfDay :: Lens' LocalTime TimeOfDay localTimeTimeOfDay f (LocalTime d t) = LocalTime d <$> f t {-# INLINE localTimeTimeOfDay #-}++-- | 'Lens' to the 'TimeOfDay component of a 'LocalTime'.+localTimeDay :: Lens' LocalTime Day+localTimeDay f (LocalTime d t) = (LocalTime ?? t) <$> f d+{-# INLINE localTimeDay #-}