diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Revision history for glirc2 +## 2.12 + +* Remove `tls-insecure` configuration option in favor of `tls: yes-insecure` +* Implement fancy command placeholder rendering and argument parsing +* Improved reconnect logic +* Improved connection error messages + ## 2.11 * Add `M-S` to jump to previously focused window diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/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/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,6 +5,39 @@ ![](https://raw.githubusercontent.com/wiki/glguy/irc-core/images/screenshot.png) +Building +======== + +Note that glirc currently requires GHC 8.0.1 + +glirc uses recent versions of packages, make sure you package databases are +up-to-date: + +``` +$ cabal update # if you're using cabal +$ stack update # if you're using stack +``` + +To install the latest version from Hackage using cabal-install: + +``` +$ cabal install glirc +``` + +Building with cabal-install from source checkout + +``` +$ cabal install --dep +$ cabal build +``` + +Building with stack using ghc-8 resolver (nightly resolvers can work using --solver) + +``` +$ stack init --resolver=ghc-8 +$ stack build +``` + Client Features =============== @@ -61,12 +94,12 @@ ``` -- Defaults used when not specified on command line defaults: - port: 6667 nick: "yournick" username: "yourusername" realname: "Your real name" password: "IRC server password" - tls: yes -- or: no + tls: yes -- or: yes-insecure or no + -- enabling tls automatically uses port 6697 tls-client-cert: "/path/to/cert.pem" tls-client-key: "/path/to/cert.key" @@ -80,7 +113,7 @@ * name: "example" hostname: "example.com" - port: 7000 + port: 7000 -- override the default port connect-cmds: * "join #favoritechannel,#otherchannel" * "msg mybot another command" @@ -142,8 +175,7 @@ * `password` - text - server password * `sasl-username` - text - SASL username * `sasl-password` - text - SASL password -* `tls` - yes/no - use TLS to connect -* `tls-insecure` - yes/no - disable certificate validation +* `tls` - yes/yes-insecure/no - use TLS to connect (insecure mode disables certificate checks) * `tls-client-cert` - text - path to TLS client certificate * `tls-client-key` - text - path to TLS client key * `connect-cmds` - list of text - client commands to send upon connection @@ -171,6 +203,11 @@ * `window-name` - attr - attr for current window name * `activity` - attr - attr for activity notification * `mention` - attr - attr for mention notification +* `command` - attr - attr for recognized command +* `command-ready` - attr - attr for command with successful parse +* `command-required` - attr - attr for required command argument placeholder +* `command-optional` - attr - attr for optional command argument placeholder +* `command-remaining` - attr - attr for remaining command text placeholder Text Attributes --------------- diff --git a/exported_symbols.txt b/exported_symbols.txt deleted file mode 100644 --- a/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/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,5 +1,5 @@ name: glirc -version: 2.11 +version: 2.12 synopsis: Console IRC client description: Console IRC client license: ISC @@ -9,7 +9,9 @@ copyright: 2016 Eric Mertens category: Network build-type: Custom -extra-source-files: ChangeLog.md README.md exported_symbols.txt +extra-source-files: ChangeLog.md README.md + linux_exported_symbols.txt + macos_exported_symbols.txt cabal-version: >=1.23 homepage: https://github.com/glguy/irc-core bug-reports: https://github.com/glguy/irc-core/issues @@ -26,11 +28,33 @@ executable glirc2 main-is: Main.hs - other-modules: Client.CommandArguments + ghc-options: -threaded -rtsopts + + hs-source-dirs: . + default-language: Haskell2010 + + if os(Linux) + ld-options: -Wl,--dynamic-list=linux_exported_symbols.txt + if os(Darwin) + ld-options: -Wl,-exported_symbols_list,macos_exported_symbols.txt + + -- Constraints can be found on the library itself + build-depends: base, glirc, lens, text + +library + hs-source-dirs: src + include-dirs: include + includes: include/glirc-api.h + install-includes: glirc-api.h + default-language: Haskell2010 + build-tools: hsc2hs + + exposed-modules: Client.CommandArguments Client.CApi Client.CApi.Exports Client.CApi.Types Client.Commands + Client.Commands.Arguments Client.Commands.Exec Client.Commands.Interpolation Client.Commands.WordCompletion @@ -38,16 +62,19 @@ Client.Configuration.Colors Client.Configuration.ServerSettings Client.EventLoop + Client.EventLoop.Errors Client.Hook Client.Hook.Znc.Buffextras Client.Hooks Client.Image + Client.Image.Arguments Client.Image.ChannelInfo Client.Image.MaskList Client.Image.Message Client.Image.MircFormatting Client.Image.Palette Client.Image.StatusLine + Client.Image.Textbox Client.Image.UserList Client.Image.Windows Client.Message @@ -61,18 +88,17 @@ Client.State.Network Client.State.Window Config.FromConfig - LensUtils + + other-modules: LensUtils StrictUnit Paths_glirc - build-tools: hsc2hs - build-depends: base >=4.9 && <4.10, async >=2.1 && <2.2, attoparsec >=0.13 && <0.14, bytestring >=0.10.8 && <0.11, config-value >=0.5 && <0.6, - connection >=0.2.5 && <0.3, + connection >=0.2.6 && <0.3, containers >=0.5.7 && <0.6, data-default-class >=0.1.2 && <0.2, deepseq >=1.4 && <1.5, @@ -95,17 +121,15 @@ unix >=2.7 && <2.8, unordered-containers >=0.2.7 && <0.3, vector >=0.11 && <0.12, - vty >=5.8 && <5.9, + vty >=5.9.1 && <5.10, x509 >=1.6.3 && <1.7, x509-store >=1.6.1 && <1.7, x509-system >=1.6.3 && <1.7 - ghc-options: -threaded -rtsopts - hs-source-dirs: src - include-dirs: include - includes: include/glirc-api.h - install-includes: include/glirc-api.h +test-suite test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: base, glirc, + HUnit >=1.3 && <1.4 default-language: Haskell2010 - - if os(Linux) - ld-options: -Wl,--dynamic-list=exported_symbols.txt diff --git a/include/glirc-api.h b/include/glirc-api.h new file mode 100644 --- /dev/null +++ b/include/glirc-api.h @@ -0,0 +1,63 @@ +#ifndef GLIRC_API +#define GLIRC_API + +#include + +enum message_code { + NORMAL_MESSAGE = 0, + ERROR_MESSAGE = 1 +}; + +enum process_result { + PASS_MESSAGE = 0, + DROP_MESSAGE = 1 +}; + +struct glirc_string { + const char *str; + size_t len; +}; + +struct glirc_message { + struct glirc_string network; + struct glirc_string prefix_nick; + struct glirc_string prefix_user; + struct glirc_string prefix_host; + struct glirc_string command; + struct glirc_string *params; + size_t params_n; + struct glirc_string *tagkeys; + struct glirc_string *tagvals; + size_t tags_n; +}; + +struct glirc_command { + struct glirc_string *params; + size_t params_n; +}; + +typedef void *start_type (void *glirc, const char *path); +typedef void stop_type (void *glirc, void *S); +typedef enum process_result process_message_type(void *glirc, void *S, const struct glirc_message *); +typedef void process_command_type(void *glirc, void *S, const struct glirc_command *); + +struct glirc_extension { + char *name; + int major_version, minor_version; + start_type *start; + stop_type *stop; + process_message_type *process_message; + process_command_type *process_command; +}; + +int glirc_send_message(void *glirc, const struct glirc_message *); +int glirc_print(void *glirc, enum message_code, struct glirc_string msg); +char ** glirc_list_networks(void *glirc); +char ** glirc_list_channels(void *glirc, struct glirc_string network); +char ** glirc_list_channel_users(void *glirc, struct glirc_string network, struct glirc_string channel); +char * glirc_my_nick(void *glirc, struct glirc_string network); +void glirc_mark_seen(void *glirc, struct glirc_string network, struct glirc_string channel); +void glirc_clear_window(void *glirc, struct glirc_string network, struct glirc_string channel); +int glirc_identifier_cmp(struct glirc_string s, struct glirc_string t); + +#endif diff --git a/linux_exported_symbols.txt b/linux_exported_symbols.txt new file mode 100644 --- /dev/null +++ b/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/macos_exported_symbols.txt b/macos_exported_symbols.txt new file mode 100644 --- /dev/null +++ b/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/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, OverloadedStrings #-} +{-# LANGUAGE BangPatterns, OverloadedStrings, ExistentialQuantification #-} {-| Module : Client.Commands @@ -16,9 +16,13 @@ , execute , executeUserCommand , tabCompletion + -- * Commands + , Command(..) + , commands ) where import Client.CApi +import Client.Commands.Arguments import Client.Commands.Exec import Client.Commands.Interpolation import Client.Commands.WordCompletion @@ -31,6 +35,7 @@ import Client.State.Focus import Client.State.Network import Client.State.Window +import Control.Applicative import Control.Lens import Control.Monad import Data.Char @@ -39,7 +44,6 @@ import Data.HashSet (HashSet) import Data.List.Split import qualified Data.HashMap.Strict as HashMap -import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as Text import Data.Monoid ((<>)) @@ -54,42 +58,40 @@ -- | Possible results of running a command data CommandResult + -- | Continue running the client, consume input if command was from input = CommandSuccess ClientState - -- ^ Continue running the client, consume input if command was from input + -- | Continue running the client, report an error | CommandFailure ClientState - -- ^ Continue running the client, report an error - | CommandQuit ClientState -- ^ Client should close + -- | Client should close + | CommandQuit ClientState + -- | Type of commands that always work -type ClientCommand = - ClientState -> - String {- ^ command arguments -} -> - IO CommandResult +type ClientCommand a = ClientState -> a {- ^ arguments -} -> IO CommandResult -- | Type of commands that require an active network to be focused -type NetworkCommand = - NetworkState {- ^ focused connection state -} -> - ClientState -> - String {- ^ command arguments -} -> - IO CommandResult +type NetworkCommand a = NetworkState {- ^ current network -} -> ClientCommand a -- | Type of commands that require an active channel to be focused -type ChannelCommand = - NetworkState {- ^ focused connection state -} -> - Identifier {- ^ focused channel -} -> - ClientState -> - String {- ^ command arguments -} -> - IO CommandResult +type ChannelCommand a = Identifier {- ^ focused channel -} -> NetworkCommand a + -- | Pair of implementations for executing a command and tab completing one. -- The tab-completion logic is extended with a bool -- indicating that tab completion should be reversed -data Command - = ClientCommand ClientCommand (Bool -> ClientCommand) -- ^ no requirements - | NetworkCommand NetworkCommand (Bool -> NetworkCommand) -- ^ requires an active network - | ChatCommand ChannelCommand (Bool -> ChannelCommand) -- ^ requires an active chat window - | ChannelCommand ChannelCommand (Bool -> ChannelCommand) -- ^ requires an active channel window +data CommandImpl a + -- | no requirements + = ClientCommand (ClientCommand a) (Bool -> ClientCommand String) + -- | requires an active network + | NetworkCommand (NetworkCommand a) (Bool -> NetworkCommand String) + -- | requires an active chat window + | ChatCommand (ChannelCommand a) (Bool -> ChannelCommand String) + -- | requires an active channel window + | ChannelCommand (ChannelCommand a) (Bool -> ChannelCommand String) +-- | Pair of a command and it's argument specification +data Command = forall a. Command (ArgumentSpec a) (CommandImpl a) + -- | Consider the text entry successful and resume the client commandSuccess :: Monad m => ClientState -> m CommandResult commandSuccess = return . CommandSuccess @@ -156,7 +158,7 @@ tabCompletion isReversed st = case snd $ clientLine st of '/':command -> executeCommand (Just isReversed) command st - _ -> commandSuccess (nickTabCompletion isReversed st) + _ -> nickTabCompletion isReversed st -- | Treat the current text input as a chat message and send it. executeChat :: String -> ClientState -> IO CommandResult @@ -178,17 +180,7 @@ _ -> commandFailureMsg "This command requires an active channel" st -splitWord :: String -> (String, String) -splitWord str = (w, drop 1 rest) - where - (w, rest) = break isSpace str -nextWord :: String -> Maybe (String, String) -nextWord str = - case splitWord (dropWhile isSpace str) of - (a,b) | null a -> Nothing - | otherwise -> Just (a,b) - -- | 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 @@ -198,40 +190,47 @@ | Just st' <- commandNameCompletion isReversed st = commandSuccess st' executeCommand tabCompleteReversed str st = - let (cmd, rest) = splitWord str - cmdTxt = Text.toLower (Text.pack cmd) in + let (cmd, rest) = break (==' ') str + cmdTxt = Text.toLower (Text.pack cmd) + + finish spec exec tab = + case tabCompleteReversed of + Just isReversed -> tab isReversed st rest + Nothing -> + case parseArguments spec rest of + Nothing -> commandFailure st + Just arg -> exec st arg + in case HashMap.lookup cmdTxt commands of Nothing -> case tabCompleteReversed of Nothing -> commandFailureMsg "Unknown command" st - Just isReversed -> commandSuccess (nickTabCompletion isReversed st) + Just isReversed -> nickTabCompletion isReversed st - Just (ClientCommand exec tab) -> - maybe exec tab tabCompleteReversed - st rest + Just (Command argSpec impl) -> + case impl of + ClientCommand exec tab -> + finish argSpec exec tab - Just (NetworkCommand exec tab) - | Just network <- views clientFocus focusNetwork st - , Just cs <- preview (clientConnection network) st -> - maybe exec tab tabCompleteReversed - cs st rest - | otherwise -> commandFailureMsg "This command requires an active network" st + NetworkCommand exec tab + | Just network <- views clientFocus focusNetwork st + , Just cs <- preview (clientConnection network) st -> + finish argSpec (exec cs) (\x -> tab x cs) + | otherwise -> commandFailureMsg "This command requires an active network" st - Just (ChannelCommand exec tab) - | ChannelFocus network channelId <- view clientFocus st - , Just cs <- preview (clientConnection network) st - , isChannelIdentifier cs channelId -> - maybe exec tab tabCompleteReversed - cs channelId st rest - | otherwise -> commandFailureMsg "This command requires an active channel" st + ChannelCommand exec tab + | ChannelFocus network channelId <- view clientFocus st + , Just cs <- preview (clientConnection network) st + , isChannelIdentifier cs channelId -> + finish argSpec (exec channelId cs) (\x -> tab x channelId cs) + | otherwise -> commandFailureMsg "This command requires an active channel" st - Just (ChatCommand exec tab) - | ChannelFocus network channelId <- view clientFocus st - , Just cs <- preview (clientConnection network) st -> - maybe exec tab tabCompleteReversed - cs channelId st rest - | otherwise -> commandFailureMsg "This command requires an active chat window" st + ChatCommand exec tab + | ChannelFocus network channelId <- view clientFocus st + , Just cs <- preview (clientConnection network) st -> + finish argSpec (exec channelId cs) (\x -> tab x channelId cs) + | otherwise -> commandFailureMsg "This command requires an active chat window" st -- Expands each alias to have its own copy of the command callbacks expandAliases :: [([a],b)] -> [(a,b)] @@ -240,90 +239,223 @@ commands :: HashMap Text Command commands = HashMap.fromList $ expandAliases - [ (["connect" ], ClientCommand cmdConnect tabConnect) - , (["exit" ], ClientCommand cmdExit noClientTab) - , (["focus" ], ClientCommand cmdFocus tabFocus) - , (["clear" ], ClientCommand cmdClear noClientTab) - , (["reconnect" ], ClientCommand cmdReconnect noClientTab) - , (["ignore" ], ClientCommand cmdIgnore simpleClientTab) - , (["reload" ], ClientCommand cmdReload tabReload) - , (["extension" ], ClientCommand cmdExtension simpleClientTab) - , (["windows" ], ClientCommand cmdWindows noClientTab) - , (["exec" ], ClientCommand cmdExec simpleClientTab) - , (["quote" ], NetworkCommand cmdQuote simpleNetworkTab) - , (["j","join" ], NetworkCommand cmdJoin simpleNetworkTab) - , (["c","channel"], NetworkCommand cmdChannel simpleNetworkTab) - , (["mode" ], NetworkCommand cmdMode tabMode) - , (["msg" ], NetworkCommand cmdMsg simpleNetworkTab) - , (["notice" ], NetworkCommand cmdNotice simpleNetworkTab) - , (["ctcp" ], NetworkCommand cmdCtcp simpleNetworkTab) - , (["nick" ], NetworkCommand cmdNick simpleNetworkTab) - , (["quit" ], NetworkCommand cmdQuit simpleNetworkTab) - , (["disconnect"], NetworkCommand cmdDisconnect noNetworkTab) - , (["who" ], NetworkCommand cmdWho simpleNetworkTab) - , (["whois" ], NetworkCommand cmdWhois simpleNetworkTab) - , (["whowas" ], NetworkCommand cmdWhowas simpleNetworkTab) - , (["ison" ], NetworkCommand cmdIson simpleNetworkTab) - , (["userhost" ], NetworkCommand cmdUserhost simpleNetworkTab) - , (["away" ], NetworkCommand cmdAway simpleNetworkTab) - , (["links" ], NetworkCommand cmdLinks simpleNetworkTab) - , (["time" ], NetworkCommand cmdTime simpleNetworkTab) - , (["stats" ], NetworkCommand cmdStats simpleNetworkTab) - , (["znc" ], NetworkCommand cmdZnc simpleNetworkTab) - , (["znc-playback"], NetworkCommand cmdZncPlayback noNetworkTab) + -- + -- Client commands + -- + [ ( ["connect"] + , Command (ReqTokenArg "network" NoArg) + $ ClientCommand cmdConnect tabConnect + ) + , ( ["exit"] + , Command NoArg + $ ClientCommand cmdExit noClientTab + ) + , ( ["focus"] + , Command (ReqTokenArg "network" (OptTokenArg "channel" NoArg)) + $ ClientCommand cmdFocus tabFocus + ) + , ( ["clear"] + , Command (OptTokenArg "network" (OptTokenArg "channel" NoArg)) + $ ClientCommand cmdClear noClientTab + ) + , ( ["reconnect"] + , Command NoArg + $ ClientCommand cmdReconnect noClientTab + ) + , ( ["ignore"] + , Command (RemainingArg "nicks") + $ ClientCommand cmdIgnore simpleClientTab + ) + , ( ["reload"] + , Command (OptTokenArg "filename" NoArg) + $ ClientCommand cmdReload tabReload + ) + , ( ["extension"] + , Command (ReqTokenArg "extension" (RemainingArg "arguments")) + $ ClientCommand cmdExtension simpleClientTab + ) + , ( ["windows"] + , Command NoArg + $ ClientCommand cmdWindows noClientTab + ) + , ( ["exec"] + , Command (RemainingArg "arguments") + $ ClientCommand cmdExec simpleClientTab + ) - , (["invite" ], ChannelCommand cmdInvite simpleChannelTab) - , (["topic" ], ChannelCommand cmdTopic tabTopic ) - , (["kick" ], ChannelCommand cmdKick simpleChannelTab) - , (["kickban" ], ChannelCommand cmdKickBan simpleChannelTab) - , (["remove" ], ChannelCommand cmdRemove simpleChannelTab) - , (["part" ], ChannelCommand cmdPart simpleChannelTab) + -- + -- Network commands + -- + , ( ["quote"] + , Command (RemainingArg "raw IRC command") + $ NetworkCommand cmdQuote simpleNetworkTab + ) + , ( ["j","join"] + , Command (ReqTokenArg "channels" (OptTokenArg "keys" NoArg)) + $ NetworkCommand cmdJoin simpleNetworkTab + ) + , ( ["c","channel"] + , Command (ReqTokenArg "channel" NoArg) + $ NetworkCommand cmdChannel simpleNetworkTab + ) + , ( ["mode"] + , Command (RemainingArg "modes and parameters") + $ NetworkCommand cmdMode tabMode + ) + , ( ["msg"] + , Command (ReqTokenArg "target" (RemainingArg "message")) + $ NetworkCommand cmdMsg simpleNetworkTab + ) + , ( ["notice"] + , Command (ReqTokenArg "target" (RemainingArg "message")) + $ NetworkCommand cmdNotice simpleNetworkTab + ) + , ( ["ctcp"] + , Command (ReqTokenArg "target" (ReqTokenArg "command" (RemainingArg "arguments"))) + $ NetworkCommand cmdCtcp simpleNetworkTab + ) + , ( ["nick"] + , Command (ReqTokenArg "nick" NoArg) + $ NetworkCommand cmdNick simpleNetworkTab + ) + , ( ["quit"] + , Command (RemainingArg "quit message") + $ NetworkCommand cmdQuit simpleNetworkTab + ) + , ( ["disconnect"] + , Command NoArg + $ NetworkCommand cmdDisconnect noNetworkTab + ) + , ( ["who"] + , Command (RemainingArg "arguments") + $ NetworkCommand cmdWho simpleNetworkTab + ) + , ( ["whois"] + , Command (RemainingArg "arguments") + $ NetworkCommand cmdWhois simpleNetworkTab + ) + , ( ["whowas"] + , Command (RemainingArg "arguments") + $ NetworkCommand cmdWhowas simpleNetworkTab + ) + , ( ["ison"] + , Command (RemainingArg "arguments") + $ NetworkCommand cmdIson simpleNetworkTab + ) + , ( ["userhost"] + , Command (RemainingArg "arguments") + $ NetworkCommand cmdUserhost simpleNetworkTab + ) + , ( ["away"] + , Command (RemainingArg "arguments") + $ NetworkCommand cmdAway simpleNetworkTab + ) + , ( ["links"] + , Command (RemainingArg "arguments") + $ NetworkCommand cmdLinks simpleNetworkTab + ) + , ( ["time"] + , Command (RemainingArg "arguments") + $ NetworkCommand cmdTime simpleNetworkTab + ) + , ( ["stats"] + , Command (RemainingArg "arguments") + $ NetworkCommand cmdStats simpleNetworkTab + ) + , ( ["znc"] + , Command (RemainingArg "arguments") + $ NetworkCommand cmdZnc simpleNetworkTab + ) + , ( ["znc-playback"] + , Command (RemainingArg "arguments") + $ NetworkCommand cmdZncPlayback noNetworkTab + ) - , (["users" ], ChannelCommand cmdUsers noChannelTab) - , (["channelinfo"], ChannelCommand cmdChannelInfo noChannelTab) - , (["masks" ], ChannelCommand cmdMasks noChannelTab) + , ( ["invite"] + , Command (ReqTokenArg "nick" NoArg) + $ ChannelCommand cmdInvite simpleChannelTab + ) + , ( ["topic"] + , Command (RemainingArg "message") + $ ChannelCommand cmdTopic tabTopic + ) + , ( ["kick"] + , Command (ReqTokenArg "nick" (RemainingArg "reason")) + $ ChannelCommand cmdKick simpleChannelTab + ) + , ( ["kickban"] + , Command (ReqTokenArg "nick" (RemainingArg "reason")) + $ ChannelCommand cmdKickBan simpleChannelTab + ) + , ( ["remove"] + , Command (ReqTokenArg "nick" (RemainingArg "reason")) + $ ChannelCommand cmdRemove simpleChannelTab + ) + , ( ["part"] + , Command (RemainingArg "reason") + $ ChannelCommand cmdPart simpleChannelTab + ) - , (["me" ], ChatCommand cmdMe simpleChannelTab) - , (["say" ], ChatCommand cmdSay simpleChannelTab) + , ( ["users"] + , Command NoArg + $ ChannelCommand cmdUsers noChannelTab + ) + , ( ["channelinfo"] + , Command NoArg + $ ChannelCommand cmdChannelInfo noChannelTab + ) + , ( ["masks"] + , Command (ReqTokenArg "mode" NoArg) + $ ChannelCommand cmdMasks noChannelTab + ) + + , ( ["me"] + , Command (RemainingArg "message") + $ ChatCommand cmdMe simpleChannelTab + ) + , ( ["say"] + , Command (RemainingArg "message") + $ ChatCommand cmdSay simpleChannelTab + ) ] -noClientTab :: Bool -> ClientCommand +noClientTab :: Bool -> ClientCommand String noClientTab _ st _ = commandFailure st -noNetworkTab :: Bool -> NetworkCommand +noNetworkTab :: Bool -> NetworkCommand String noNetworkTab _ _ st _ = commandFailure st -noChannelTab :: Bool -> ChannelCommand +noChannelTab :: Bool -> ChannelCommand String noChannelTab _ _ _ st _ = commandFailure st -simpleClientTab :: Bool -> ClientCommand +simpleClientTab :: Bool -> ClientCommand String simpleClientTab isReversed st _ = - commandSuccess (nickTabCompletion isReversed st) + nickTabCompletion isReversed st -simpleNetworkTab :: Bool -> NetworkCommand +simpleNetworkTab :: Bool -> NetworkCommand String simpleNetworkTab isReversed _ st _ = - commandSuccess (nickTabCompletion isReversed st) + nickTabCompletion isReversed st -simpleChannelTab :: Bool -> ChannelCommand +simpleChannelTab :: Bool -> ChannelCommand String simpleChannelTab isReversed _ _ st _ = - commandSuccess (nickTabCompletion isReversed st) + nickTabCompletion isReversed st -cmdExit :: ClientCommand +cmdExit :: ClientCommand () cmdExit st _ = return (CommandQuit st) -- | When used on a channel that the user is currently -- joined to this command will clear the messages but -- preserve the window. When used on a window that the -- user is not joined to this command will delete the window. -cmdClear :: ClientCommand -cmdClear st rest = - case Text.pack <$> words rest of - [] -> clearFocus (view clientFocus st) - ["*"] -> clearFocus Unfocused - [network] -> clearFocus (NetworkFocus network) - [network,channel] -> clearFocus (ChannelFocus network (mkId channel)) - _ -> commandFailureMsg "Usage: /clear [network] [channel]" st +cmdClear :: ClientCommand (Maybe (String, Maybe (String, ()))) +cmdClear st args = + case args of + Nothing -> clearFocus (view clientFocus st) + Just ("*", Nothing) -> clearFocus Unfocused + Just (network, Nothing) -> clearFocus (NetworkFocus (Text.pack network)) + Just (network, Just (channel, _)) -> + clearFocus (ChannelFocus (Text.pack network) (mkId (Text.pack channel))) where clearFocus focus = commandSuccess (windowEffect st) where @@ -344,7 +476,7 @@ .csChannels . ix channel) st -cmdQuote :: NetworkCommand +cmdQuote :: NetworkCommand String cmdQuote cs st rest = case parseRawIrcMsg (Text.pack rest) of Nothing -> commandFailureMsg "Failed to parse IRC command" st @@ -353,8 +485,8 @@ commandSuccess st -- | Implementation of @/me@ -cmdMe :: ChannelCommand -cmdMe cs channelId st rest = +cmdMe :: ChannelCommand String +cmdMe channelId cs st rest = do now <- getZonedTime let actionTxt = Text.pack ("\^AACTION " ++ rest ++ "\^A") !myNick = UserInfo (view csNick cs) "" "" @@ -369,31 +501,23 @@ $ recordChannelMessage network channelId entry st -- | Implementation of @/ctcp@ -cmdCtcp :: NetworkCommand -cmdCtcp cs st rest = - case parse of - Nothing -> commandFailureMsg "Usage: /ctcp TARGET COMMAND ARGS" st - Just (target, cmd, args) -> - do let cmdTxt = Text.toUpper (Text.pack cmd) - argTxt = Text.pack args - tgtTxt = Text.pack target +cmdCtcp :: NetworkCommand (String, (String, String)) +cmdCtcp cs st (target, (cmd, args)) = + do let cmdTxt = Text.toUpper (Text.pack cmd) + argTxt = Text.pack args + tgtTxt = Text.pack target - sendMsg cs (ircPrivmsg (mkId tgtTxt) ("\^A" <> cmdTxt <> " " <> argTxt <> "\^A")) - chatCommand - (\src tgt -> Ctcp src tgt cmdTxt argTxt) - tgtTxt cs st - where - parse = - do (target, rest1) <- nextWord rest - (cmd , args ) <- nextWord rest1 - return (target, cmd, args) + sendMsg cs (ircPrivmsg (mkId tgtTxt) ("\^A" <> cmdTxt <> " " <> argTxt <> "\^A")) + chatCommand + (\src tgt -> Ctcp src tgt cmdTxt argTxt) + tgtTxt cs st -- | Implementation of @/notice@ -cmdNotice :: NetworkCommand -cmdNotice cs st rest = - case nextWord rest of - Just (target, rest1) | not (null rest1) -> - do let restTxt = Text.pack rest1 +cmdNotice :: NetworkCommand (String, String) +cmdNotice cs st (target, rest) + | null rest = commandFailure st + | otherwise = + do let restTxt = Text.pack rest tgtTxt = Text.pack target sendMsg cs (ircNotice (mkId tgtTxt) restTxt) @@ -401,21 +525,18 @@ (\src tgt -> Notice src tgt restTxt) tgtTxt cs st - _ -> commandFailureMsg "Usage: /notice TARGET MESSAGE" st - -- | Implementation of @/msg@ -cmdMsg :: NetworkCommand -cmdMsg cs st rest = - case nextWord rest of - Just (target, rest1) | not (null rest1) -> - do let restTxt = Text.pack rest1 +cmdMsg :: NetworkCommand (String, String) +cmdMsg cs st (target, rest) + | null rest = commandFailure st + | otherwise = + do let restTxt = Text.pack rest tgtTxt = Text.pack target sendMsg cs (ircPrivmsg (mkId tgtTxt) restTxt) chatCommand (\src tgt -> Privmsg src tgt restTxt) tgtTxt cs st - _ -> commandFailureMsg "Usage: /msg TARGET MESSAGE" st -- | Common logic for @/msg@ and @/notice@ chatCommand :: @@ -454,57 +575,59 @@ entries -cmdConnect :: ClientCommand -cmdConnect st rest = - case words rest of - [networkStr] -> - do -- abort any existing connection before connecting - let network = Text.pack networkStr - st' <- addConnection network =<< abortNetwork network st - commandSuccess - $ changeFocus (NetworkFocus network) st' - - _ -> commandFailureMsg "Usage: /connect NETWORK" st - -cmdFocus :: ClientCommand -cmdFocus st rest = - case words rest of - ["*"] -> - commandSuccess (changeFocus Unfocused st) - - [network] -> - let focus = NetworkFocus (Text.pack network) in - commandSuccess (changeFocus focus st) - - [network,channel] -> - let focus = ChannelFocus (Text.pack network) (mkId (Text.pack channel)) in - commandSuccess - $ changeFocus focus st +cmdConnect :: ClientCommand (String, ()) +cmdConnect st (networkStr, _) = + do -- abort any existing connection before connecting + let network = Text.pack networkStr + st' <- addConnection 0 Nothing network =<< abortNetwork network st + commandSuccess + $ changeFocus (NetworkFocus network) st' - _ -> commandFailureMsg "Focus requires a network and an optional channel" st +cmdFocus :: ClientCommand (String, Maybe (String, ())) +cmdFocus st (network, mbChannel) + | network == "*" = commandSuccess (changeFocus Unfocused st) + | otherwise = + case mbChannel of + Nothing -> + let focus = NetworkFocus (Text.pack network) in + commandSuccess (changeFocus focus st) + Just (channel,_) -> + let focus = ChannelFocus (Text.pack network) (mkId (Text.pack channel)) in + commandSuccess + $ changeFocus focus st -- | Implementation of @/windows@ command. Set subfocus to Windows. -cmdWindows :: ClientCommand -cmdWindows st _rest = commandSuccess (changeSubfocus FocusWindows st) +cmdWindows :: ClientCommand () +cmdWindows st _ = commandSuccess (changeSubfocus FocusWindows st) +simpleTabCompletion :: + Prefix a => + (String -> String) {- ^ leading transform -} -> + [a] {- ^ hints -} -> + [a] {- ^ all completions -} -> + Bool {- ^ reversed order -} -> + ClientState -> IO CommandResult +simpleTabCompletion lead hints completions isReversed st = + case traverseOf clientTextBox tryCompletion st of + Nothing -> commandFailure st + Just st' -> commandSuccess st' + where + tryCompletion = wordComplete lead isReversed hints completions -- | @/connect@ tab completes known server names -tabConnect :: Bool -> ClientCommand -tabConnect isReversed st _ - = commandSuccess - $ fromMaybe st - $ clientTextBox (wordComplete id isReversed [] networks) st +tabConnect :: Bool -> ClientCommand String +tabConnect isReversed st _ = + simpleTabCompletion id [] networks isReversed st where - networks = HashMap.keys $ view clientNetworkMap st + networks = views clientNetworkMap HashMap.keys st + ++ views (clientConfig . configServers) HashMap.keys st -- | When tab completing the first parameter of the focus command -- the current networks are used. -tabFocus :: Bool -> ClientCommand -tabFocus isReversed st _ - = commandSuccess - $ fromMaybe st - $ clientTextBox (wordComplete id isReversed [] completions) st +tabFocus :: Bool -> ClientCommand String +tabFocus isReversed st _ = + simpleTabCompletion id [] completions isReversed st where networks = map mkId $ HashMap.keys $ view clientNetworkMap st params = words $ uncurry take $ clientLine st @@ -513,58 +636,58 @@ | length params == 2 = networks | otherwise = currentCompletionList st -cmdWhois :: NetworkCommand +cmdWhois :: NetworkCommand String cmdWhois cs st rest = do sendMsg cs (ircWhois (Text.pack <$> words rest)) commandSuccess st -cmdWho :: NetworkCommand +cmdWho :: NetworkCommand String cmdWho cs st rest = do sendMsg cs (ircWho (Text.pack <$> words rest)) commandSuccess st -cmdWhowas :: NetworkCommand +cmdWhowas :: NetworkCommand String cmdWhowas cs st rest = do sendMsg cs (ircWhowas (Text.pack <$> words rest)) commandSuccess st -cmdIson :: NetworkCommand +cmdIson :: NetworkCommand String cmdIson cs st rest = do sendMsg cs (ircIson (Text.pack <$> words rest)) commandSuccess st -cmdUserhost :: NetworkCommand +cmdUserhost :: NetworkCommand String cmdUserhost cs st rest = do sendMsg cs (ircUserhost (Text.pack <$> words rest)) commandSuccess st -cmdStats :: NetworkCommand +cmdStats :: NetworkCommand String cmdStats cs st rest = do sendMsg cs (ircStats (Text.pack <$> words rest)) commandSuccess st -cmdAway :: NetworkCommand +cmdAway :: NetworkCommand String cmdAway cs st rest = do sendMsg cs (ircAway (Text.pack rest)) commandSuccess st -cmdLinks :: NetworkCommand +cmdLinks :: NetworkCommand String cmdLinks cs st rest = do sendMsg cs (ircLinks (Text.pack <$> words rest)) commandSuccess st -cmdTime :: NetworkCommand +cmdTime :: NetworkCommand String cmdTime cs st rest = do sendMsg cs (ircTime (Text.pack <$> words rest)) commandSuccess st -cmdZnc :: NetworkCommand +cmdZnc :: NetworkCommand String cmdZnc cs st rest = do sendMsg cs (ircZnc (Text.words (Text.pack rest))) commandSuccess st -- TODO: support time ranges -cmdZncPlayback :: NetworkCommand +cmdZncPlayback :: NetworkCommand String cmdZncPlayback cs st rest = case words rest of @@ -604,49 +727,42 @@ do sendMsg cs (ircZnc ["*playback", "play", "*", Text.pack start]) commandSuccess st -cmdMode :: NetworkCommand +cmdMode :: NetworkCommand String cmdMode cs st rest = modeCommand (Text.pack <$> words rest) cs st -cmdNick :: NetworkCommand -cmdNick cs st rest = - case words rest of - [nick] -> - do sendMsg cs (ircNick (mkId (Text.pack nick))) - commandSuccess st - _ -> commandFailureMsg "Usage: /nick NICK" st +cmdNick :: NetworkCommand (String, ()) +cmdNick cs st (nick,_) = + do sendMsg cs (ircNick (mkId (Text.pack nick))) + commandSuccess st -cmdPart :: ChannelCommand -cmdPart cs channelId st rest = +cmdPart :: ChannelCommand String +cmdPart channelId cs st rest = do let msg = rest sendMsg cs (ircPart channelId (Text.pack msg)) commandSuccess st -- | This command is equivalent to chatting without a command. The primary use -- at the moment is to be able to send a leading @/@ to chat easily. -cmdSay :: ChannelCommand -cmdSay _cs _channelId st rest = executeChat rest st - -cmdInvite :: ChannelCommand -cmdInvite cs channelId st rest = - case words rest of - [nick] -> - do let freeTarget = has (csChannels . ix channelId . chanModes . ix 'g') cs - cmd = ircInvite (Text.pack nick) channelId - cs' <- if freeTarget - then cs <$ sendMsg cs cmd - else sendModeration channelId [cmd] cs - commandSuccessUpdateCS cs' st +cmdSay :: ChannelCommand String +cmdSay _ _ st rest = executeChat rest st - _ -> commandFailureMsg "Usage: /invite NICK" st +cmdInvite :: ChannelCommand (String, ()) +cmdInvite channelId cs st (nick,_) = + do let freeTarget = has (csChannels . ix channelId . chanModes . ix 'g') cs + cmd = ircInvite (Text.pack nick) channelId + cs' <- if freeTarget + then cs <$ sendMsg cs cmd + else sendModeration channelId [cmd] cs + commandSuccessUpdateCS cs' st -commandSuccessUpdateCS :: NetworkState -> ClientState -> IO CommandResult +commandSuccessUpdateCS :: NetworkState -> ClientState -> IO CommandResult commandSuccessUpdateCS cs st = let networkId = view csNetworkId cs in commandSuccess $ setStrict (clientConnections . ix networkId) cs st -cmdTopic :: ChannelCommand -cmdTopic cs channelId st rest = +cmdTopic :: ChannelCommand String +cmdTopic channelId cs st rest = do let cmd = case rest of "" -> ircTopic channelId "" @@ -659,8 +775,8 @@ tabTopic :: Bool {- ^ reversed -} -> - ChannelCommand -tabTopic _ cs channelId st rest + ChannelCommand String +tabTopic _ channelId cs st rest | all isSpace rest , Just topic <- preview (csChannels . ix channelId . chanTopic) cs = @@ -670,45 +786,39 @@ | otherwise = commandFailure st -cmdUsers :: ChannelCommand +cmdUsers :: ChannelCommand () cmdUsers _ _ st _ = commandSuccess (changeSubfocus FocusUsers st) -cmdChannelInfo :: ChannelCommand +cmdChannelInfo :: ChannelCommand () cmdChannelInfo _ _ st _ = commandSuccess (changeSubfocus FocusInfo st) -cmdMasks :: ChannelCommand -cmdMasks cs _ st rest = - case words rest of - [[mode]] | mode `elem` view (csModeTypes . modesLists) cs -> +cmdMasks :: ChannelCommand (String,()) +cmdMasks _ cs st (rest,_) = + case rest of + [mode] | mode `elem` view (csModeTypes . modesLists) cs -> commandSuccess (changeSubfocus (FocusMasks mode) st) _ -> commandFailureMsg "Unknown mask mode" st -cmdKick :: ChannelCommand -cmdKick cs channelId st rest = - case nextWord rest of - Nothing -> commandFailureMsg "Usage: /kick NICK [MESSAGE]" st - Just (who,reason) -> - do let msg = Text.pack reason - cmd = ircKick channelId (Text.pack who) msg - cs' <- sendModeration channelId [cmd] cs - commandSuccessUpdateCS cs' st +cmdKick :: ChannelCommand (String, String) +cmdKick channelId cs st (who,reason) = + do let msg = Text.pack reason + cmd = ircKick channelId (Text.pack who) msg + cs' <- sendModeration channelId [cmd] cs + commandSuccessUpdateCS cs' st -cmdKickBan :: ChannelCommand -cmdKickBan cs channelId st rest = - case nextWord rest of - Nothing -> commandFailureMsg "Usage: /kickban NICK [MESSAGE]" st - Just (whoStr,reason) -> - do let msg = Text.pack reason +cmdKickBan :: ChannelCommand (String, String) +cmdKickBan channelId cs st (who,reason) = + do let msg = Text.pack reason - whoTxt = Text.pack whoStr + whoTxt = Text.pack who - mask = renderUserInfo (computeBanUserInfo (mkId whoTxt) cs) - cmds = [ ircMode channelId ["b", mask] - , ircKick channelId whoTxt msg - ] - cs' <- sendModeration channelId cmds cs - commandSuccessUpdateCS cs' st + mask = renderUserInfo (computeBanUserInfo (mkId whoTxt) cs) + cmds = [ ircMode channelId ["b", mask] + , ircKick channelId whoTxt msg + ] + cs' <- sendModeration channelId cmds cs + commandSuccessUpdateCS cs' st computeBanUserInfo :: Identifier -> NetworkState -> UserInfo computeBanUserInfo who cs = @@ -716,49 +826,37 @@ Nothing -> UserInfo who "*" "*" Just (UserAndHost _ host) -> UserInfo "*" "*" host -cmdRemove :: ChannelCommand -cmdRemove cs channelId st rest = - case nextWord rest of - Nothing -> commandFailureMsg "Usage: /remove NICK [MESSAGE]" st - Just (who,reason) -> - do let msg = Text.pack reason - cmd = ircRemove channelId (Text.pack who) msg - cs' <- sendModeration channelId [cmd] cs - commandSuccessUpdateCS cs' st +cmdRemove :: ChannelCommand (String, String) +cmdRemove channelId cs st (who,reason) = + do let msg = Text.pack reason + cmd = ircRemove channelId (Text.pack who) msg + cs' <- sendModeration channelId [cmd] cs + commandSuccessUpdateCS cs' st -cmdJoin :: NetworkCommand -cmdJoin cs st rest = - let ws = words rest - network = view csNetwork cs - doJoin channelStr keyStr = - do let channelId = mkId (Text.pack (takeWhile (/=',') channelStr)) - sendMsg cs (ircJoin (Text.pack channelStr) (Text.pack <$> keyStr)) - commandSuccess - $ changeFocus (ChannelFocus network channelId) st - in case ws of - [channel] -> doJoin channel Nothing - [channel,key] -> doJoin channel (Just key) - _ -> commandFailureMsg "Usage: /join CHANNELS [KEYS]" st +cmdJoin :: NetworkCommand (String, Maybe (String, ())) +cmdJoin cs st (channels, mbKeys) = + do let network = view csNetwork cs + let channelId = mkId (Text.pack (takeWhile (/=',') channels)) + sendMsg cs (ircJoin (Text.pack channels) (Text.pack . fst <$> mbKeys)) + commandSuccess + $ changeFocus (ChannelFocus network channelId) st -- | @/channel@ command. Takes the name of a channel and switches -- focus to that channel on the current network. -cmdChannel :: NetworkCommand -cmdChannel cs st rest = - case mkId . Text.pack <$> words rest of - [ channelId ] -> - commandSuccess - $ changeFocus (ChannelFocus (view csNetwork cs) channelId) st - _ -> commandFailureMsg "Usage: /channel CHANNEL" st +cmdChannel :: NetworkCommand (String, ()) +cmdChannel cs st (channel, _) = + commandSuccess + $ changeFocus (ChannelFocus (view csNetwork cs) (mkId (Text.pack channel))) st -cmdQuit :: NetworkCommand +cmdQuit :: NetworkCommand String cmdQuit cs st rest = do let msg = Text.pack rest sendMsg cs (ircQuit msg) commandSuccess st -cmdDisconnect :: NetworkCommand +cmdDisconnect :: NetworkCommand () cmdDisconnect cs st _ = do st' <- abortNetwork (view csNetwork cs) st commandSuccess st' @@ -766,17 +864,18 @@ -- | Reconnect to the currently focused network. It's possible -- that we're not currently connected to a network, so -- this is implemented as a client command. -cmdReconnect :: ClientCommand +cmdReconnect :: ClientCommand () cmdReconnect st _ | Just network <- views clientFocus focusNetwork st = - do st' <- addConnection network =<< abortNetwork network st + do tm <- getCurrentTime + st' <- addConnection 0 (Just tm) network =<< abortNetwork network st commandSuccess $ changeFocus (NetworkFocus network) st' | otherwise = commandFailureMsg "/reconnect requires focused network" st -cmdIgnore :: ClientCommand +cmdIgnore :: ClientCommand String cmdIgnore st rest = case mkId . Text.pack <$> words rest of [] -> commandFailure st @@ -790,10 +889,10 @@ -- | Implementation of @/reload@ -- -- Attempt to reload the configuration file -cmdReload :: ClientCommand -cmdReload st rest = - do let path | null rest = view (clientConfig . configConfigPath) st - | otherwise = Just rest +cmdReload :: ClientCommand (Maybe (String, ())) +cmdReload st mbPath = + do let path = fst <$> mbPath + <|> view (clientConfig . configConfigPath) st res <- loadConfiguration path case res of Left e -> commandFailureMsg (describeProblem e) st @@ -813,7 +912,7 @@ -- configuration file. -- -- /NOT IMPLEMENTED/ -tabReload :: Bool {- ^ reversed -} -> ClientCommand +tabReload :: Bool {- ^ reversed -} -> ClientCommand String tabReload _ st _ = commandFailure st modeCommand :: @@ -855,7 +954,7 @@ _ -> commandFailure st -tabMode :: Bool -> NetworkCommand +tabMode :: Bool -> NetworkCommand String tabMode isReversed cs st rest = case view clientFocus st of @@ -866,11 +965,9 @@ [ (pol,mode) | (pol,mode,arg) <- parsedModes, not (Text.null arg) ] , (pol,mode):_ <- drop (paramIndex-3) parsedModesWithParams , let (hint, completions) = computeModeCompletion pol mode channel cs st - -> commandSuccess - $ fromMaybe st - $ clientTextBox (wordComplete id isReversed hint completions) st + -> simpleTabCompletion id hint completions isReversed st - _ -> commandSuccess st + _ -> commandFailure st where paramIndex = length $ words $ uncurry take $ clientLine st @@ -886,9 +983,14 @@ . winMessages . folded . wlBody . _IrcBody . folding msgActor . to userNick - . filtered isActive) st + . filtered isActive + . filtered isNotSelf ) st where isActive n = HashMap.member n userMap + self = preview ( clientConnection network . csNick ) st + isNotSelf n = case self of + Nothing -> True + Just s -> n /= s userMap = view ( clientConnection network . csChannels . ix channel . chanUsers) st @@ -943,13 +1045,12 @@ -- | Complete the nickname at the current cursor position using the -- userlist for the currently focused channel (if any) -nickTabCompletion :: Bool {- ^ reversed -} -> ClientState -> ClientState -nickTabCompletion isReversed st - = fromMaybe st - $ clientTextBox (wordComplete (++": ") isReversed hint completions) st +nickTabCompletion :: Bool {- ^ reversed -} -> ClientState -> IO CommandResult +nickTabCompletion isReversed st = + simpleTabCompletion (++": ") hint completions isReversed st where - hint = activeNicks st - completions = currentCompletionList st + hint = activeNicks st + completions = currentCompletionList st -- | Used to send commands that require ops to perform. -- If this channel is one that the user has chanserv access and ops are needed @@ -971,21 +1072,18 @@ channel `elem` view (csSettings . ssChanservChannels) cs && not (iHaveOp channel cs) -cmdExtension :: ClientCommand -cmdExtension st rest = - case Text.words (Text.pack rest) of - name:params -> - case find (\ae -> aeName ae == name) - (view (clientExtensions . esActive) st) of +cmdExtension :: ClientCommand (String, String) +cmdExtension st (name,params) = + case find (\ae -> aeName ae == Text.pack name) + (view (clientExtensions . esActive) st) of Nothing -> commandFailureMsg "Unknown extension" st Just ae -> do (st',_) <- clientPark st $ \ptr -> - commandExtension ptr params ae + commandExtension ptr (Text.pack <$> words params) ae commandSuccess st' - _ -> commandFailureMsg "Usage: /extension EXTENSION ARGUMENTS" st -- | Implementation of @/exec@ command. -cmdExec :: ClientCommand +cmdExec :: ClientCommand String cmdExec st rest = do now <- getZonedTime case parseExecCmd rest of diff --git a/src/Client/Commands/Arguments.hs b/src/Client/Commands/Arguments.hs new file mode 100644 --- /dev/null +++ b/src/Client/Commands/Arguments.hs @@ -0,0 +1,63 @@ +{-# Language GADTs, KindSignatures #-} + +{-| +Module : Client.Commands.Arguments +Description : Command argument description and parsing +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module provides a description for the arguments expected +by command commands as well as a way to parse those arguments. +-} + +module Client.Commands.Arguments + ( ArgumentSpec(..) + , parseArguments + ) where + +import Control.Monad + +-- | Description of a command's arguments indexed by the result of parsing +-- those arguments. Arguments are annotated with a 'String' describing the +-- argument. +data ArgumentSpec :: * -> * where + + -- | A required space-delimited token + ReqTokenArg :: String -> ArgumentSpec rest -> ArgumentSpec (String, rest) + + -- | An optional space-delimited token + OptTokenArg :: String -> ArgumentSpec rest -> ArgumentSpec (Maybe (String, rest)) + + -- | Take all the remaining text in free-form + RemainingArg :: String -> ArgumentSpec String + + -- | No arguments + NoArg :: ArgumentSpec () + + +-- | Parse the given input string using an argument specification. +-- The arguments should start with a space but might have more. +parseArguments :: + ArgumentSpec a {- ^ specification -} -> + String {- ^ input string -} -> + Maybe a {- ^ parse results -} +parseArguments arg xs = + case arg of + NoArg -> guard (all (==' ') xs) + RemainingArg _ -> Just (drop 1 xs) -- drop the leading space + OptTokenArg _ rest -> + do let (tok, xs') = nextToken xs + if null tok + then Just Nothing + else do rest' <- parseArguments rest xs' + return (Just (tok, rest')) + ReqTokenArg _ rest -> + do let (tok, xs') = nextToken xs + guard (not (null tok)) + rest' <- parseArguments rest xs' + return (tok, rest') + +-- | Return the next space delimited token. Leading space is dropped. +nextToken :: String -> (String, String) +nextToken = break (==' ') . dropWhile (==' ') diff --git a/src/Client/Commands/WordCompletion.hs b/src/Client/Commands/WordCompletion.hs --- a/src/Client/Commands/WordCompletion.hs +++ b/src/Client/Commands/WordCompletion.hs @@ -9,7 +9,8 @@ -} module Client.Commands.WordCompletion - ( wordComplete + ( Prefix + , wordComplete ) where import qualified Client.State.EditBox as Edit @@ -94,7 +95,7 @@ , isPrefix pat next = Just next - | isReversed = find (isPrefix pat) (reverse (Set.toList valSet)) + | isReversed = find (isPrefix pat) (Set.toDescList valSet) | otherwise = do x <- Set.lookupGE pat valSet guard (isPrefix pat x) diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -206,19 +206,24 @@ when (null xs) (failure "Empty palette") return $! set palNicks xs p - "self" -> setAttr palSelf - "self-highlight" -> setAttrMb palSelfHighlight - "time" -> setAttr palTime - "meta" -> setAttr palMeta - "sigil" -> setAttr palSigil - "label" -> setAttr palLabel - "latency" -> setAttr palLatency - "error" -> setAttr palError - "textbox" -> setAttr palTextBox - "window-name" -> setAttr palWindowName - "activity" -> setAttr palActivity - "mention" -> setAttr palMention - _ -> failure "Unknown palette entry" + "self" -> setAttr palSelf + "self-highlight" -> setAttrMb palSelfHighlight + "time" -> setAttr palTime + "meta" -> setAttr palMeta + "sigil" -> setAttr palSigil + "label" -> setAttr palLabel + "latency" -> setAttr palLatency + "error" -> setAttr palError + "textbox" -> setAttr palTextBox + "window-name" -> setAttr palWindowName + "activity" -> setAttr palActivity + "mention" -> setAttr palMention + "command" -> setAttr palCommand + "command-ready" -> setAttr palCommandReady + "command-required" -> setAttr palCommandRequired + "command-optional" -> setAttr palCommandOptional + "command-remaining" -> setAttr palCommandRemaining + _ -> failure "Unknown palette entry" where setAttr l = do !attr <- parseAttr v @@ -252,8 +257,7 @@ "sasl-password" -> setFieldMb ssSaslPassword "hostname" -> setFieldWith ssHostName parseString "port" -> setFieldWithMb ssPort parseNum - "tls" -> setFieldWith ssTls parseBoolean - "tls-insecure" -> setFieldWith ssTlsInsecure parseBoolean + "tls" -> setFieldWith ssTls parseUseTls "tls-client-cert" -> setFieldWithMb ssTlsClientCert parseString "tls-client-key" -> setFieldWithMb ssTlsClientKey parseString "server-certificates" -> setFieldWith ssServerCerts (parseList parseString) @@ -278,10 +282,11 @@ do x <- p v return $! set l (Just x) ss -parseBoolean :: Value -> ConfigParser Bool -parseBoolean (Atom "yes") = return True -parseBoolean (Atom "no") = return False -parseBoolean _ = failure "expected yes or no" +parseUseTls :: Value -> ConfigParser UseTls +parseUseTls (Atom "yes") = return UseTls +parseUseTls (Atom "yes-insecure") = return UseInsecure +parseUseTls (Atom "no") = return UseInsecure +parseUseTls _ = failure "expected yes, yes-insecure, or no" parseNum :: Num a => Value -> ConfigParser a parseNum v = fromInteger <$> parseConfig v 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 @@ -26,7 +26,6 @@ , ssHostName , ssPort , ssTls - , ssTlsInsecure , ssTlsClientCert , ssTlsClientKey , ssConnectCmds @@ -42,17 +41,19 @@ -- * Load function , loadDefaultServerSettings + -- * TLS settings + , UseTls(..) + ) where import Control.Lens import Data.Maybe (fromMaybe) import Data.Text (Text) +import qualified Data.Text as Text import Irc.Identifier (Identifier) +import Network.Socket (HostName, PortNumber) import System.Environment -import qualified Data.Text as Text -import Network.Socket (HostName, PortNumber) - -- | Static server-level settings data ServerSettings = ServerSettings { _ssNick :: !Text -- ^ connection nickname @@ -64,8 +65,7 @@ , _ssSaslPassword :: !(Maybe Text) -- ^ SASL password , _ssHostName :: !HostName -- ^ server hostname , _ssPort :: !(Maybe PortNumber) -- ^ server port - , _ssTls :: !Bool -- ^ use TLS to connect - , _ssTlsInsecure :: !Bool -- ^ disable certificate checking + , _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 @@ -80,6 +80,12 @@ } deriving Show +data UseTls + = UseTls -- ^ TLS connection + | UseInsecureTls -- ^ TLS connection without certificate checking + | UseInsecure -- ^ Plain connection + deriving Show + makeLenses ''ServerSettings -- | Load the defaults for server settings based on the environment @@ -100,8 +106,7 @@ , _ssSaslPassword = Text.pack <$> lookup "SASLPASSWORD" env , _ssHostName = "" , _ssPort = Nothing - , _ssTls = False - , _ssTlsInsecure = False + , _ssTls = UseInsecure , _ssTlsClientCert = Nothing , _ssTlsClientKey = Nothing , _ssConnectCmds = [] diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -19,6 +19,7 @@ import Client.Commands import Client.Configuration import Client.Configuration.ServerSettings +import Client.EventLoop.Errors (exceptionToLines) import Client.Hook import Client.Hooks import Client.Image @@ -43,12 +44,15 @@ import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding.Error as Text import Data.Time -import GHC.IO.Exception (IOErrorType(ResourceVanished), ioe_type) +import GHC.IO.Exception (IOErrorType(..), ioe_type) import Graphics.Vty import Irc.Codes import Irc.Message import Irc.RawIrcMsg +import Network.Connection +reconnectAttempts :: Int +reconnectAttempts = 6 -- | Sum of the three possible event types the event loop handles data ClientEvent @@ -115,7 +119,7 @@ -- | Sound the terminal bell assuming that the @BEL@ control code -- is supported. beep :: Vty -> IO () -beep vty = outputByteBuffer (outputIface vty) "\BEL" +beep = ringTerminalBell . outputIface -- | Respond to a network connection closing normally. doNetworkClose :: @@ -140,22 +144,46 @@ ClientState -> IO () doNetworkError networkId time ex st = do let (cs,st1) = removeNetwork networkId st - msg = ClientMessage + st2 = foldl' (flip recordNetworkMessage) st1 msgs + + msgs = [ ClientMessage { _msgTime = time , _msgNetwork = view csNetwork cs - , _msgBody = ErrorBody (Text.pack (displayException ex)) + , _msgBody = ErrorBody (Text.pack e) } + | e <- exceptionToLines ex ] - shouldReconnect - | Just PingTimeout <- fromException ex = True - | Just ResourceVanished <- ioe_type <$> fromException ex = True - | otherwise = False + shouldReconnect = + case view csPingStatus cs of + PingConnecting n _ + | n == 0 || n > reconnectAttempts -> False + _ | Just HostNotResolved{} <- fromException ex -> True + | Just HostCannotConnect{} <- fromException ex -> True + | Just PingTimeout <- fromException ex -> True + | Just ResourceVanished <- ioe_type <$> fromException ex -> True + | Just NoSuchThing <- ioe_type <$> fromException ex -> True + + | otherwise -> False + + + reconnect = do + (delaySecs, 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 + nextAction - | shouldReconnect = addConnection (view csNetwork cs) - | otherwise = return + | shouldReconnect = reconnect + | otherwise = return st2 - eventLoop =<< nextAction (recordNetworkMessage msg st1) + eventLoop =<< nextAction -- | Respond to an IRC protocol line. This will parse the message, updated the diff --git a/src/Client/EventLoop/Errors.hs b/src/Client/EventLoop/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Client/EventLoop/Errors.hs @@ -0,0 +1,98 @@ +{-| +Module : Client.EventLoop.Errors +Description : Human-readable versions of connection failure +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module provides a prettier rendering for exceptions that are +common in network connects as well as hints about what causes these +errors. +-} + +module Client.EventLoop.Errors + ( exceptionToLines + ) where + +import Control.Exception +import Data.Char +import Network.Connection +import Network.TLS + +-- | Compute the message message text to be used for a connection error +exceptionToLines :: + SomeException {- ^ network error -} -> + [String] {- ^ client lines -} +exceptionToLines + = indentMessages + . map cleanLine + . exceptionToLines' + +indentMessages :: [String] -> [String] +indentMessages [] = ["PANIC: No error message generated"] +indentMessages (x:xs) = x : map ("⋯ "++) xs + +cleanLine :: String -> String +cleanLine = map $ \x -> + case x of + '\n' -> '⏎' + '\t' -> ' ' + _ | isControl x -> '�' + | otherwise -> x + +exceptionToLines' :: + SomeException {- ^ network error -} -> + [String] {- ^ client lines -} +exceptionToLines' ex + + -- TLS package errors + | Just tls <- fromException ex = explainTLSException tls + + -- connection package errors + | Just (HostNotResolved str) <- fromException ex = + ["Host not resolved: " ++ str] + + | Just (HostCannotConnect str exs) <- fromException ex = + ("Host cannot connect: " ++ str) + : concatMap explainIOError exs + + -- IOErrors, typically network package. + | Just ioe <- fromException ex = + explainIOError ioe + + -- Anything else including glirc's errors (which use displayException) + | otherwise = [displayException ex] + +explainIOError :: IOError -> [String] +explainIOError ioe = + ["IO error: " ++ displayException ioe] + +explainTLSException :: TLSException -> [String] +explainTLSException ex = + case ex of + ConnectionNotEstablished -> + ["Attempt to use connection out of order"] + Terminated _ _ tlsError -> + "Connection closed due to early-termination in TLS layer" + : explainTLSError tlsError + HandshakeFailed (Error_Packet_Parsing 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 -> [String] +explainTLSError ex = + case ex of + Error_Misc str -> ["Miscellaneous error: " ++ str] + Error_Protocol (str, _, _desc) -> ["Protocol error: " ++ str] + Error_Certificate str -> ["Certificate error: " ++ str] + Error_HandshakePolicy str -> ["Handshake policy: " ++ str] + Error_EOF -> ["Unexpected end of connection"] + Error_Packet str -> ["Packet error: " ++ str] + Error_Packet_unexpected msg expect -> ("Packet unexpected: " ++ msg) + : [ expect | not (null expect) ] + Error_Packet_Parsing str -> ["Packet parse error: " ++ str] diff --git a/src/Client/Image.hs b/src/Client/Image.hs --- a/src/Client/Image.hs +++ b/src/Client/Image.hs @@ -15,21 +15,17 @@ import Client.Image.ChannelInfo import Client.Image.MaskList import Client.Image.Message -import Client.Image.MircFormatting import Client.Image.Palette import Client.Image.StatusLine +import Client.Image.Textbox import Client.Image.UserList import Client.Image.Windows import Client.Message import Client.State -import qualified Client.State.EditBox as Edit import Client.State.Focus import Client.State.Network import Client.State.Window import Control.Lens -import Data.Char -import Data.List -import qualified Data.Text as Text import Graphics.Vty (Background(..), Picture(..), Cursor(..)) import Graphics.Vty.Image import Irc.Identifier (Identifier) @@ -192,69 +188,3 @@ | otherwise = img <|> char defAttr ' ' -- trailing space with default attributes deals with bug in VTY -- where the formatting will continue past the end of chat messages - - -textboxImage :: ClientState -> (Int, Image) -textboxImage st - = (pos, croppedImage) - where - width = view clientWidth st - (txt, content) = - views (clientTextBox . Edit.content) renderContent st - - pos = computeCharWidth (width-1) txt - - lineImage = beginning <|> content <|> ending - - leftOfCurWidth = myWcswidth txt - - croppedImage - | leftOfCurWidth < width = lineImage - | otherwise = cropLeft width (cropRight (leftOfCurWidth+1) lineImage) - - attr = view (clientConfig . configPalette . palTextBox) st - beginning = char attr '^' - ending = char attr '$' - -renderContent :: Edit.Content -> (String, Image) -renderContent c = (txt, wholeImg) - where - as = reverse (view Edit.above c) - bs = view Edit.below c - cur = view Edit.line c - - leftCur = take (view Edit.pos cur) (view Edit.text cur) - - renderLine l = parseIrcTextExplicit $ Text.pack l - - inputLines = as ++ view Edit.text cur : bs - - -- ["one","two"] "three" --> "^two one three" - txt = '^' : foldl (\acc x -> x++' ':acc) leftCur as - - wholeImg = horizCat - $ intersperse (renderLine "\n") - $ map renderLine inputLines - -computeCharWidth :: Int -> String -> Int -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 'safeWcwidth' that accounts for how control characters are --- rendered -myWcwidth :: Char -> Int -myWcwidth x - | isControl x = 1 - | otherwise = safeWcwidth x - --- | Version of 'safeWcswidth' that accounts for how control characters are --- rendered -myWcswidth :: String -> Int -myWcswidth = sum . map myWcwidth diff --git a/src/Client/Image/Arguments.hs b/src/Client/Image/Arguments.hs new file mode 100644 --- /dev/null +++ b/src/Client/Image/Arguments.hs @@ -0,0 +1,69 @@ +{-# Language GADTs #-} + +{-| +Module : Client.Image.Arguments +Description : Rendering logic for commanad arguments +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +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 + +argumentsImage :: Palette -> ArgumentSpec a -> String -> Image +argumentsImage pal spec xs + | all (==' ') xs = placeholders + <|> string defAttr (drop (imageWidth placeholders) xs) + | otherwise = + case spec of + NoArg -> plainText xs + ReqTokenArg _ a -> plainText token <|> argumentsImage pal a xs' + OptTokenArg _ a -> plainText token <|> argumentsImage pal a xs' + RemainingArg _ -> parseIrcTextExplicit (Text.pack xs) + + where + token = token1 ++ token2 + (token1,(token2,xs')) = + break (==' ') <$> span (==' ') xs + + placeholders = mkPlaceholders pal spec + +-- | Construct an 'Image' containing placeholders for each +-- of the remaining arguments. +mkPlaceholders :: Palette -> ArgumentSpec a -> Image +mkPlaceholders pal arg = + case arg of + NoArg -> emptyImage + ReqTokenArg n a -> leader + <|> string (view palCommandRequired pal) n + <|> mkPlaceholders pal a + OptTokenArg n a -> leader + <|> string (view palCommandOptional pal) n + <|> mkPlaceholders pal a + RemainingArg n -> leader + <|> string (view palCommandRemaining pal) n + where + leader = char defAttr ' ' 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,11 +13,13 @@ module Client.Image.MircFormatting ( parseIrcText , parseIrcTextExplicit + , controlImage ) where import Control.Applicative ((<|>)) import Control.Lens import Data.Attoparsec.Text as Parse +import Data.Bits import Data.Char import Data.Maybe import Data.Text (Text) @@ -83,7 +85,7 @@ do (numberText, colorNumbers) <- match pColorNumbers rest <- pIrcLine explicit (applyColors colorNumbers fmt) return $ if explicit - then Vty.char controlAttr 'C' + then controlImage '\^C' Vty.<|> text' defAttr numberText Vty.<|> rest else rest @@ -91,7 +93,7 @@ -- always render control codes that we don't understand | isNothing mbFmt' || explicit -> do rest <- next - return (Vty.char controlAttr (controlName c) Vty.<|> rest) + return (controlImage c Vty.<|> rest) | otherwise -> next where mbFmt' = applyControlEffect c fmt @@ -147,8 +149,11 @@ applyControlEffect '\^_' = Just . over fmtUnderline not applyControlEffect _ = const Nothing -controlAttr :: Attr -controlAttr = defAttr `withStyle` reverseVideo - -controlName :: Char -> Char -controlName c = chr (ord '@' + ord c) +-- | Safely render a control character. +controlImage :: Char -> Image +controlImage = Vty.char attr . controlName + where + attr = withStyle defAttr reverseVideo + controlName c + | c < '\128' = chr (0x40 `xor` ord c) + | otherwise = '!' diff --git a/src/Client/Image/Palette.hs b/src/Client/Image/Palette.hs --- a/src/Client/Image/Palette.hs +++ b/src/Client/Image/Palette.hs @@ -25,6 +25,11 @@ , palTextBox , palActivity , palMention + , palCommand + , palCommandReady + , palCommandRequired + , palCommandOptional + , palCommandRemaining -- * Defaults , defaultPalette @@ -36,19 +41,24 @@ -- | Color palette used for rendering the client UI data Palette = Palette - { _palNicks :: Vector Attr -- ^ colors for highlighting nicknames - , _palSelf :: Attr -- ^ color of our own nickname(s) - , _palSelfHighlight :: Maybe Attr -- ^ color of our own nickname(s) in mentions - , _palTime :: Attr -- ^ color of message timestamps - , _palMeta :: Attr -- ^ color of coalesced metadata - , _palSigil :: Attr -- ^ color of sigils (e.g. @+) - , _palLabel :: Attr -- ^ color of information labels - , _palLatency :: Attr -- ^ color of ping latency - , _palWindowName :: Attr -- ^ color of window name - , _palError :: Attr -- ^ color of error messages - , _palTextBox :: Attr -- ^ color of textbox markers - , _palActivity :: Attr -- ^ color of window name with activity - , _palMention :: Attr -- ^ color of window name with mention + { _palNicks :: Vector Attr -- ^ highlighting nicknames + , _palSelf :: Attr -- ^ own nickname(s) + , _palSelfHighlight :: Maybe Attr -- ^ own nickname(s) in mentions + , _palTime :: Attr -- ^ message timestamps + , _palMeta :: Attr -- ^ coalesced metadata + , _palSigil :: Attr -- ^ sigils (e.g. @+) + , _palLabel :: Attr -- ^ information labels + , _palLatency :: Attr -- ^ ping latency + , _palWindowName :: Attr -- ^ window name + , _palError :: Attr -- ^ error messages + , _palTextBox :: Attr -- ^ textbox markers + , _palActivity :: Attr -- ^ window name with activity + , _palMention :: Attr -- ^ window name with mention + , _palCommand :: Attr -- ^ known command + , _palCommandReady :: Attr -- ^ known command with complete arguments + , _palCommandRequired :: Attr -- ^ required argument placeholder + , _palCommandOptional :: Attr -- ^ optional argument placeholder + , _palCommandRemaining :: Attr -- ^ remaining command text placeholder } deriving Show @@ -57,19 +67,24 @@ -- | Default UI colors that look nice in my dark solarized color scheme defaultPalette :: Palette defaultPalette = Palette - { _palNicks = defaultNickColorPalette - , _palSelf = withForeColor defAttr red - , _palSelfHighlight = Nothing - , _palTime = withForeColor defAttr brightBlack - , _palMeta = withForeColor defAttr brightBlack - , _palSigil = withForeColor defAttr cyan - , _palLabel = withForeColor defAttr green - , _palLatency = withForeColor defAttr yellow - , _palWindowName = withForeColor defAttr cyan - , _palError = withForeColor defAttr red - , _palTextBox = withForeColor defAttr brightBlack - , _palActivity = withForeColor defAttr green - , _palMention = withForeColor defAttr red + { _palNicks = defaultNickColorPalette + , _palSelf = withForeColor defAttr red + , _palSelfHighlight = Nothing + , _palTime = withForeColor defAttr brightBlack + , _palMeta = withForeColor defAttr brightBlack + , _palSigil = withForeColor defAttr cyan + , _palLabel = withForeColor defAttr green + , _palLatency = withForeColor defAttr yellow + , _palWindowName = withForeColor defAttr cyan + , _palError = withForeColor defAttr red + , _palTextBox = withForeColor defAttr brightBlack + , _palActivity = withForeColor defAttr green + , _palMention = withForeColor defAttr red + , _palCommand = withForeColor defAttr yellow + , _palCommandReady = withForeColor defAttr green + , _palCommandRequired = withStyle defAttr reverseVideo + , _palCommandOptional = withStyle defAttr reverseVideo + , _palCommandRemaining = withStyle defAttr reverseVideo } -- | Default nick highlighting colors that look nice in my dark solarized 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 @@ -61,23 +61,27 @@ , Just cs <- preview (clientConnection network) st = case view csPingStatus cs of PingNever -> emptyImage - PingSent {} -> emptyImage - PingLatency delta -> horizCat - [ string defAttr "─(" - , string (view palLatency pal) (showFFloat (Just 2) delta "s") - , string defAttr ")" - ] + PingSent {} -> infoBubble (string (view palLatency pal) "sent") + PingLatency delta -> + infoBubble (string (view palLatency pal) (showFFloat (Just 2) delta "s")) + PingConnecting n _ -> + infoBubble (string (view palLabel pal) "connecting" <|> retryImage) + where + retryImage + | n > 0 = string defAttr ": " <|> + string (view palLabel pal) + (shows n (if n == 1 then "retry" else "retries")) + | otherwise = emptyImage | otherwise = emptyImage where pal = view (clientConfig . configPalette) st +infoBubble :: Image -> Image +infoBubble img = string defAttr "─(" <|> img <|> string defAttr ")" + detailImage :: ClientState -> Image detailImage st - | view clientDetailView st = horizCat - [ string defAttr "─(" - , string attr "detail" - , string defAttr ")" - ] + | view clientDetailView st = infoBubble (string attr "detail") | otherwise = emptyImage where attr = view (clientConfig . configPalette . palLabel) st diff --git a/src/Client/Image/Textbox.hs b/src/Client/Image/Textbox.hs new file mode 100644 --- /dev/null +++ b/src/Client/Image/Textbox.hs @@ -0,0 +1,115 @@ +{-# Language BangPatterns #-} + +{-| +Module : Client.Image.Textbox +Description : Textbox renderer +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module provides the renderer for the client's text box input. + +-} + +module Client.Image.Textbox where + +import Client.Configuration +import Client.Commands +import Client.Commands.Arguments +import Client.Image.Arguments +import Client.Image.MircFormatting +import Client.Image.Palette +import Client.State +import qualified Client.State.EditBox as Edit +import Control.Lens +import Data.Char +import Data.List +import qualified Data.Text as Text +import Graphics.Vty.Image + +textboxImage :: ClientState -> (Int, Image) +textboxImage st + = (pos, croppedImage) + where + width = view clientWidth st + (txt, content) = + views (clientTextBox . Edit.content) (renderContent pal) st + + pos = computeCharWidth (width-1) txt + + pal = view (clientConfig . configPalette) st + + lineImage = beginning <|> content <|> ending + + leftOfCurWidth = myWcswidth txt + + croppedImage + | leftOfCurWidth < width = lineImage + | otherwise = cropLeft width (cropRight (leftOfCurWidth+1) lineImage) + + attr = view (clientConfig . configPalette . palTextBox) st + beginning = char attr '^' + ending = char attr '$' + +renderContent :: Palette -> Edit.Content -> (String, Image) +renderContent pal c = (txt, wholeImg) + where + as = reverse (view Edit.above c) + bs = view Edit.below c + cur = view Edit.line c + + leftCur = take (view Edit.pos cur) (view Edit.text cur) + + -- ["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 + +-- | 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 +myWcwidth :: Char -> Int +myWcwidth x + | isControl x = 1 + | otherwise = wcwidth x + +-- | Version of 'wcswidth' that accounts for how control characters are +-- rendered +myWcswidth :: String -> Int +myWcswidth = sum . map myWcwidth + + +renderLine :: Palette -> String -> Image + +renderLine pal ('/':xs) + | (cmd,rest) <- break isSpace xs + , Just (Command spec _) <- view (at (Text.pack cmd)) commands + , let attr = + case parseArguments spec rest of + Nothing -> view palCommand pal + Just{} -> view palCommandReady pal + = char defAttr '/' <|> + string attr cmd <|> + argumentsImage pal spec rest + +renderLine _ xs = parseIrcTextExplicit (Text.pack xs) diff --git a/src/Client/Image/Windows.hs b/src/Client/Image/Windows.hs --- a/src/Client/Image/Windows.hs +++ b/src/Client/Image/Windows.hs @@ -29,7 +29,7 @@ $ zipWith (renderWindowColumns pal) names windows where cfg = view clientConfig st - windows = views clientWindows Map.toList st + windows = views clientWindows Map.toAscList st pal = view configPalette cfg names = views configWindowNames Text.unpack cfg ++ repeat '?' diff --git a/src/Client/Network/Async.hs b/src/Client/Network/Async.hs --- a/src/Client/Network/Async.hs +++ b/src/Client/Network/Async.hs @@ -98,15 +98,18 @@ -- 'NetworkConnection' value can be used for sending outgoing messages and for -- early termination of the connection. createConnection :: + Int {- ^ delay in seconds -} -> NetworkId {- ^ Identifier to be used on incoming events -} -> ConnectionContext -> ServerSettings -> TQueue NetworkEvent {- Queue for incoming events -} -> IO NetworkConnection -createConnection network cxt settings inQueue = +createConnection delay network cxt settings inQueue = do outQueue <- atomically newTQueue - supervisor <- async (startConnection network cxt settings inQueue outQueue) + supervisor <- async $ + threadDelay (delay * 1000000) >> + startConnection network cxt settings inQueue outQueue -- Having this reporting thread separate from the supervisor ensures -- that canceling the supervisor with abortConnection doesn't interfere diff --git a/src/Client/Network/Connect.hs b/src/Client/Network/Connect.hs --- a/src/Client/Network/Connect.hs +++ b/src/Client/Network/Connect.hs @@ -36,9 +36,9 @@ buildConnectionParams :: ServerSettings -> IO ConnectionParams buildConnectionParams args = - do useSecure <- if view ssTls args - then fmap Just (buildTlsSettings args) - else return Nothing + do useSecure <- case view ssTls args of + UseInsecure -> return Nothing + _ -> Just <$> buildTlsSettings args let proxySettings = view ssSocksHost args <&> \host -> SockSettingsSimple @@ -56,8 +56,10 @@ ircPort args = case view ssPort args of Just p -> fromIntegral p - Nothing | view ssTls args -> 6697 - | otherwise -> 6667 + Nothing -> + case view ssTls args of + UseInsecure -> 6667 + _ -> 6697 buildCertificateStore :: ServerSettings -> IO CertificateStore buildCertificateStore args = @@ -85,7 +87,9 @@ , clientShared = def { sharedCAStore = store , sharedValidationCache = - if view ssTlsInsecure args then noValidation else def + case view ssTls args of + UseInsecureTls -> noValidation + _ -> def } , clientHooks = def { onCertificateRequest = \_ -> loadClientCredentials args } diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -505,8 +505,14 @@ Just i | i == networkId -> (cs,Nothing) _ -> (cs,mb) -addConnection :: Text -> ClientState -> IO ClientState -addConnection network st = +-- | Start a new connection. The delay is used for reconnections. +addConnection :: + Int {- ^ delay in seconds -} -> + Maybe UTCTime {- ^ optional disconnect time -} -> + Text {- ^ network name -} -> + ClientState -> + IO ClientState +addConnection attempts lastTime network st = do let defSettings = (view (clientConfig . configDefaults) st) { _ssName = Just network , _ssHostName = Text.unpack network @@ -516,13 +522,15 @@ $ preview (clientConfig . configServers . ix network) st let (i,st') = st & clientNextConnectionId <+~ 1 + delay = 15 * attempts c <- createConnection + delay i (view clientConnectionContext st') settings (view clientEvents st') - let cs = newNetworkState i network settings c + let cs = newNetworkState i network settings c (PingConnecting attempts lastTime) traverse_ (sendMsg cs) (initialMessages cs) return $ set (clientNetworkMap . at network) (Just i) @@ -638,7 +646,7 @@ Just (focus,_) -> changeFocus focus st Nothing -> st where - windowList = views clientWindows Map.toList st + windowList = views clientWindows Map.toAscList st highPriority = find (view winMention . snd) windowList lowPriority = find (\x -> view winUnread (snd x) > 0) windowList diff --git a/src/Client/State/EditBox/Content.hs b/src/Client/State/EditBox/Content.hs --- a/src/Client/State/EditBox/Content.hs +++ b/src/Client/State/EditBox/Content.hs @@ -188,9 +188,11 @@ -- | Insert character at cursor, cursor is advanced. insertChar :: Char -> Content -> Content -insertChar '\n' c - = over above (view text c :) - $ set line emptyLine c +insertChar '\n' c = + let Line n txt = view line c in + case splitAt n txt of + (preS, postS) -> over above (preS :) + $ set line (beginLine postS) c insertChar ins c = over line aux c where 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 @@ -124,6 +124,9 @@ = 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 deriving Show data Transaction @@ -186,8 +189,9 @@ Text -> ServerSettings -> NetworkConnection -> + PingStatus -> NetworkState -newNetworkState networkId network settings sock = NetworkState +newNetworkState networkId network settings sock ping = NetworkState { _csNetworkId = networkId , _csUserInfo = UserInfo (mkId (view ssNick settings)) "" "" , _csChannels = HashMap.empty @@ -201,7 +205,7 @@ , _csModeCount = 3 , _csUsers = HashMap.empty , _csNetwork = network - , _csPingStatus = PingNever + , _csPingStatus = ping , _csNextPingTime = Nothing , _csMessageHooks = view ssMessageHooks settings } @@ -272,6 +276,7 @@ = noReply . set csNick me . set csNextPingTime (Just $! addUTCTime 30 (zonedTimeToUTC msgWhen)) + . set csPingStatus PingNever doTopic :: ZonedTime -> UserInfo -> Identifier -> Text -> NetworkState -> NetworkState doTopic when user chan topic = @@ -765,6 +770,7 @@ PingSent{} -> TimedDisconnect PingLatency{} -> TimedSendPing PingNever -> TimedSendPing + PingConnecting{} -> TimedSendPing doPong :: ZonedTime -> NetworkState -> NetworkState doPong when cs = set csPingStatus (PingLatency delta) cs diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,67 +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.CApi.Exports () -- foreign exports -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) st networks - return (set clientFocus (NetworkFocus network) st') diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,55 @@ +{-# Language GADTs #-} +{-| +Module : Main +Description : Tests for the glirc library +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module test various components of glirc + +-} +module Main (main) where + +import Client.Commands.Arguments +import System.Exit +import Test.HUnit + +main :: IO a +main = + do outcome <- runTestTT tests + if errors outcome == 0 && failures outcome == 0 + then exitSuccess + else exitFailure + +tests :: Test +tests = test [ argumentParserTests ] + +argumentParserTests :: Test +argumentParserTests = test + [ assertEqual "no arg empty" + (Just ()) + (parseArguments NoArg "") + , assertEqual "no arg white" + (Just ()) + (parseArguments NoArg " ") + , assertEqual "no arg fail" + Nothing + (parseArguments NoArg " a") + + , assertEqual "required" + (Just ("argument",())) + (parseArguments (ReqTokenArg "field" NoArg) " argument ") + + , assertEqual "optional 1" + (Just (Just ("argument",()))) + (parseArguments (OptTokenArg "field" NoArg) " argument ") + + , assertEqual "optional 2" + (Just Nothing) + (parseArguments (OptTokenArg "field" NoArg) " ") + + , assertEqual "remaining" + (Just "some stuff ") + (parseArguments (RemainingArg "field") " some stuff ") + ]