glirc 2.11 → 2.12
raw patch · 29 files changed
+1247/−594 lines, 29 filesdep +HUnitdep +glircdep ~basedep ~connectiondep ~lens
Dependencies added: HUnit, glirc
Dependency ranges changed: base, connection, lens, text, vty
Files
- ChangeLog.md +7/−0
- Main.hs +66/−0
- README.md +42/−5
- exported_symbols.txt +0/−11
- glirc.cabal +40/−16
- include/glirc-api.h +63/−0
- linux_exported_symbols.txt +11/−0
- macos_exported_symbols.txt +9/−0
- src/Client/Commands.hs +420/−322
- src/Client/Commands/Arguments.hs +63/−0
- src/Client/Commands/WordCompletion.hs +3/−2
- src/Client/Configuration.hs +24/−19
- src/Client/Configuration/ServerSettings.hs +13/−8
- src/Client/EventLoop.hs +39/−11
- src/Client/EventLoop/Errors.hs +98/−0
- src/Client/Image.hs +1/−71
- src/Client/Image/Arguments.hs +69/−0
- src/Client/Image/MircFormatting.hs +12/−7
- src/Client/Image/Palette.hs +41/−26
- src/Client/Image/StatusLine.hs +15/−11
- src/Client/Image/Textbox.hs +115/−0
- src/Client/Image/Windows.hs +1/−1
- src/Client/Network/Async.hs +5/−2
- src/Client/Network/Connect.hs +10/−6
- src/Client/State.hs +12/−4
- src/Client/State/EditBox/Content.hs +5/−3
- src/Client/State/Network.hs +8/−2
- src/Main.hs +0/−67
- test/Main.hs +55/−0
ChangeLog.md view
@@ -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
+ Main.hs view
@@ -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')
README.md view
@@ -5,6 +5,39 @@  +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 ---------------
− exported_symbols.txt
@@ -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;-};
glirc.cabal view
@@ -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
+ include/glirc-api.h view
@@ -0,0 +1,63 @@+#ifndef GLIRC_API+#define GLIRC_API++#include <stdlib.h>++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
+ linux_exported_symbols.txt view
@@ -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;+};
+ macos_exported_symbols.txt view
@@ -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
src/Client/Commands.hs view
@@ -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
+ src/Client/Commands/Arguments.hs view
@@ -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 (==' ')
src/Client/Commands/WordCompletion.hs view
@@ -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)
src/Client/Configuration.hs view
@@ -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
src/Client/Configuration/ServerSettings.hs view
@@ -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 = []
src/Client/EventLoop.hs view
@@ -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
+ src/Client/EventLoop/Errors.hs view
@@ -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]
src/Client/Image.hs view
@@ -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
+ src/Client/Image/Arguments.hs view
@@ -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 ' '
src/Client/Image/MircFormatting.hs view
@@ -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 = '!'
src/Client/Image/Palette.hs view
@@ -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
src/Client/Image/StatusLine.hs view
@@ -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
+ src/Client/Image/Textbox.hs view
@@ -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)
src/Client/Image/Windows.hs view
@@ -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 '?'
src/Client/Network/Async.hs view
@@ -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
src/Client/Network/Connect.hs view
@@ -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 }
src/Client/State.hs view
@@ -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
src/Client/State/EditBox/Content.hs view
@@ -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
src/Client/State/Network.hs view
@@ -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
− src/Main.hs
@@ -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')
+ test/Main.hs view
@@ -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 ")+ ]