diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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` diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -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') diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 ` - 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 ` - Load a new configuration file +* `/reload [path]` - Load a new configuration file (optional path) * `/windows` - List all open windows -* `/extension ` - Send the given params to the named extension -* `/exec [-n network] [-c channel] ` - 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 ` - Send the given params to the named extension +* `/exec [-n network] [-c channel] ` - 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 diff --git a/exec/Main.hs b/exec/Main.hs new file mode 100644 --- /dev/null +++ b/exec/Main.hs @@ -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') diff --git a/exec/linux_exported_symbols.txt b/exec/linux_exported_symbols.txt new file mode 100644 --- /dev/null +++ b/exec/linux_exported_symbols.txt @@ -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; +}; diff --git a/exec/macos_exported_symbols.txt b/exec/macos_exported_symbols.txt new file mode 100644 --- /dev/null +++ b/exec/macos_exported_symbols.txt @@ -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 diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -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 diff --git a/linux_exported_symbols.txt b/linux_exported_symbols.txt deleted file mode 100644 --- a/linux_exported_symbols.txt +++ /dev/null @@ -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; -}; diff --git a/macos_exported_symbols.txt b/macos_exported_symbols.txt deleted file mode 100644 --- a/macos_exported_symbols.txt +++ /dev/null @@ -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 diff --git a/src/Client/CApi/Exports.hs b/src/Client/CApi/Exports.hs --- a/src/Client/CApi/Exports.hs +++ b/src/Client/CApi/Exports.hs @@ -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 -} -> diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -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 diff --git a/src/Client/Commands/Interpolation.hs b/src/Client/Commands/Interpolation.hs --- a/src/Client/Commands/Interpolation.hs +++ b/src/Client/Commands/Interpolation.hs @@ -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 diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -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 diff --git a/src/Client/Configuration/ServerSettings.hs b/src/Client/Configuration/ServerSettings.hs --- a/src/Client/Configuration/ServerSettings.hs +++ b/src/Client/Configuration/ServerSettings.hs @@ -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 diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -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 :: 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,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 diff --git a/src/Client/Image.hs b/src/Client/Image.hs --- a/src/Client/Image.hs +++ b/src/Client/Image.hs @@ -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] } diff --git a/src/Client/Image/Arguments.hs b/src/Client/Image/Arguments.hs --- a/src/Client/Image/Arguments.hs +++ b/src/Client/Image/Arguments.hs @@ -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 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 @@ -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 + 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 @@ -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 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 @@ -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) diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -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 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 @@ -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 diff --git a/src/LensUtils.hs b/src/LensUtils.hs --- a/src/LensUtils.hs +++ b/src/LensUtils.hs @@ -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 #-}