diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Revision history for glirc2 +## 2.4 + +* Support XDG configuration directory, e.g. `~/.config/glirc/config` +* Add more window names. Shift selects second set of names. +* Add `/channel` and `/say` +* Improve `/focus` tab completion + ## 2.3 * Add commands `/znc` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -138,10 +138,11 @@ * `/focus ` - Change focus to channel window * `/clear` - Clear contents of current window * `/ignore ` - Toggle ignore of a user +* `/channel ` - Change focus to channel on current network (alias: `/c`) Channel membership -* `/join ` - Join a channel +* `/join ` - Join a channel (alias: `/j`) * `/part` - Part from current channel Chat commands @@ -149,7 +150,8 @@ * `/msg ` - Send a message on the current server to target * `/notice ` - Send a notice message on the current server to target * `/ctcp ` - Send a ctcp command on the current server to target -* `/me` - Send action message to channel +* `/me ` - Send action message to channel +* `/say ` - Send normal message to channel Channel management @@ -198,7 +200,7 @@ * `^N` next channel * `^P` previous channel -* `M-#` jump to window - 1234567890qwertyuiop +* `M-#` jump to window - 1234567890qwertyuiop!@#$%^&*()QWERTYUIOP * `M-A` jump to activity * `^A` beginning of line * `^E` end of line diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,5 +1,5 @@ name: glirc -version: 2.3 +version: 2.4 synopsis: Console IRC client description: Console IRC client license: ISC @@ -57,6 +57,7 @@ Irc.RawIrcMsg Irc.UserInfo LensUtils + StrictUnit Paths_glirc -- other-extensions: @@ -71,11 +72,11 @@ deepseq >=1.4 && <1.5, directory >=1.2.6 && <1.3, filepath >=1.4.1 && <1.5, + gitrev >=1.2 && <1.3, hashable >=1.2.4 && <1.3, lens >=4.14 && <4.15, memory >=0.13 && <0.14, network >=2.6.2 && <2.7, - profunctors >=5.2 && <5.3, split >=0.2 && <0.3, stm >=2.4 && <2.5, text >=1.2.2 && <1.3, diff --git a/src/Client/CommandArguments.hs b/src/Client/CommandArguments.hs --- a/src/Client/CommandArguments.hs +++ b/src/Client/CommandArguments.hs @@ -26,6 +26,7 @@ import Data.Foldable import qualified Data.Text as Text import Data.Version +import Development.GitRev (gitHash, gitDirty) import System.Console.GetOpt import System.Environment import System.Exit @@ -89,7 +90,20 @@ versionTxt :: String versionTxt = unlines - [ "glirc-" ++ showVersion version + [ "glirc-" ++ showVersion version ++ gitHashTxt ++ gitDirtyTxt , "Copyright 2016 Eric Mertens" ] +-- | Returns @"-SOMEHASH"@ when in a git repository, @""@ otherwise. +gitHashTxt :: String +gitHashTxt + | hashTxt == "UNKNOWN" = "" + | otherwise = '-':hashTxt + where + hashTxt = $gitHash + +-- | Returns @"-dirty"@ when in a dirty git repository, @""@ otherwise. +gitDirtyTxt :: String +gitDirtyTxt + | $gitDirty = "-dirty" + | otherwise = "" diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -13,8 +13,8 @@ module Client.Commands ( CommandResult(..) - , executeCommand - , nickTabCompletion + , execute + , tabCompletion ) where import Client.ConnectionState @@ -60,20 +60,62 @@ -- The tab-completion logic is extended with a bool -- indicating that tab completion should be reversed data Command - = ClientCommand ClientCommand (Bool -> ClientCommand) - | NetworkCommand NetworkCommand (Bool -> NetworkCommand) - | ChannelCommand ChannelCommand (Bool -> ChannelCommand) - + = 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 +-- | Resume the client without further state changes commandContinue :: Monad m => ClientState -> m CommandResult commandContinue = return . CommandContinue +-- | Consider the text entry successful and resume the client commandSuccess :: Monad m => ClientState -> m CommandResult -commandSuccess = return . CommandContinue . consumeInput +commandSuccess = commandContinue . consumeInput +-- | Consider the text entry a failure and resume the client commandFailure :: Monad m => ClientState -> m CommandResult -commandFailure = return . CommandContinue . set clientBell True +commandFailure = commandContinue . set clientBell True +-- | Interpret whatever text is in the textbox. Leading @/@ indicates a +-- command. Otherwise if a channel or user query is focused a chat message +-- will be sent. +execute :: ClientState -> IO CommandResult +execute st = + case clientInput st of + [] -> commandFailure st + '/':command -> executeCommand Nothing command st + msg -> executeChat msg st + +-- | Respond to the TAB key being pressed. This can dispatch to a command +-- specific completion mode when relevant. Otherwise this will complete +-- input based on the users of the channel related to the current buffer. +tabCompletion :: Bool {- ^ reversed -} -> ClientState -> IO CommandResult +tabCompletion isReversed st = + case clientInput st of + '/':command -> executeCommand (Just isReversed) command st + _ -> commandContinue (nickTabCompletion isReversed st) + +-- | Treat the current text input as a chat message and send it. +executeChat :: String -> ClientState -> IO CommandResult +executeChat msg st = + case view clientFocus st of + ChannelFocus network channel + | Just cs <- preview (clientConnection network) st -> + do now <- getZonedTime + let msgTxt = Text.pack msg + ircMsg = rawIrcMsg "PRIVMSG" [idText channel, msgTxt] + myNick = UserInfo (view csNick cs) Nothing Nothing + entry = ClientMessage + { _msgTime = now + , _msgNetwork = network + , _msgBody = IrcBody (Privmsg myNick channel msgTxt) + } + sendMsg cs ircMsg + commandSuccess $ recordChannelMessage network channel entry st + + _ -> commandFailure st + splitWord :: String -> (String, String) splitWord str = (w, drop 1 rest) where @@ -115,51 +157,65 @@ maybe exec tab tabCompleteReversed network cs channelId st rest + Just (ChatCommand exec tab) + | ChannelFocus network channelId <- view clientFocus st + , Just cs <- preview (clientConnection network) st -> + maybe exec tab tabCompleteReversed + network cs channelId st rest + _ -> case tabCompleteReversed of Nothing -> commandFailure st Just isReversed -> commandContinue (nickTabCompletion isReversed st) +-- Expands each alias to have its own copy of the command callbacks +expandAliases :: [([a],b)] -> [(a,b)] +expandAliases xs = [ (a,b) | (as,b) <- xs, a <- as ] + commands :: HashMap Text Command commands = HashMap.fromList - [ ("connect" , ClientCommand cmdConnect noClientTab) - , ("exit" , ClientCommand cmdExit noClientTab) - , ("focus" , ClientCommand cmdFocus simpleClientTab) - , ("clear" , ClientCommand cmdClear noClientTab) - , ("reconnect" , ClientCommand cmdReconnect noClientTab) - , ("ignore" , ClientCommand cmdIgnore simpleClientTab) + $ expandAliases + [ (["connect" ], ClientCommand cmdConnect noClientTab) + , (["exit" ], ClientCommand cmdExit noClientTab) + , (["focus" ], ClientCommand cmdFocus tabFocus) + , (["clear" ], ClientCommand cmdClear noClientTab) + , (["reconnect" ], ClientCommand cmdReconnect noClientTab) + , (["ignore" ], ClientCommand cmdIgnore simpleClientTab) - , ("quote" , NetworkCommand cmdQuote simpleNetworkTab) - , ("join" , NetworkCommand cmdJoin 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) + , (["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) - , ("invite" , ChannelCommand cmdInvite simpleChannelTab) - , ("topic" , ChannelCommand cmdTopic tabTopic ) - , ("kick" , ChannelCommand cmdKick simpleChannelTab) - , ("kickban" , ChannelCommand cmdKickBan simpleChannelTab) - , ("remove" , ChannelCommand cmdRemove simpleChannelTab) - , ("me" , ChannelCommand cmdMe simpleChannelTab) - , ("part" , ChannelCommand cmdPart simpleChannelTab) + , (["invite" ], ChannelCommand cmdInvite simpleChannelTab) + , (["topic" ], ChannelCommand cmdTopic tabTopic ) + , (["kick" ], ChannelCommand cmdKick simpleChannelTab) + , (["kickban" ], ChannelCommand cmdKickBan simpleChannelTab) + , (["remove" ], ChannelCommand cmdRemove simpleChannelTab) + , (["part" ], ChannelCommand cmdPart simpleChannelTab) - , ("users" , ChannelCommand cmdUsers noChannelTab) - , ("channelinfo", ChannelCommand cmdChannelInfo noChannelTab) - , ("masks" , ChannelCommand cmdMasks noChannelTab) + , (["users" ], ChannelCommand cmdUsers noChannelTab) + , (["channelinfo"], ChannelCommand cmdChannelInfo noChannelTab) + , (["masks" ], ChannelCommand cmdMasks noChannelTab) + + , (["me" ], ChatCommand cmdMe simpleChannelTab) + , (["say" ], ChatCommand cmdSay simpleChannelTab) ] noClientTab :: Bool -> ClientCommand @@ -339,6 +395,23 @@ _ -> commandFailure st +-- | When tab completing the first parameter of the focus command +-- the current networks are used. +tabFocus :: Bool -> ClientCommand +tabFocus isReversed st _ + = commandContinue + $ fromMaybe st + $ clientTextBox (wordComplete id isReversed completions) st + where + networks = map mkId $ HashMap.keys $ view clientNetworkMap st + textBox = view clientTextBox st + params = words $ take (view EditBox.pos textBox) + (view EditBox.content textBox) + + completions + | length params == 2 = networks + | otherwise = currentCompletionList st + cmdWhois :: NetworkCommand cmdWhois _ cs st rest = do sendMsg cs (ircWhois (Text.pack <$> words rest)) @@ -446,6 +519,11 @@ 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 _network _cs _channelId st rest = executeChat rest st + cmdInvite :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult cmdInvite _ cs channelId st rest = case words rest of @@ -562,6 +640,17 @@ [channel] -> doJoin channel Nothing [channel,key] -> doJoin channel (Just key) _ -> commandFailure st + + +-- | @/channel@ command. Takes the name of a channel and switches +-- focus to that channel on the current network. +cmdChannel :: NetworkCommand +cmdChannel network _ st rest = + case mkId . Text.pack <$> words rest of + [ channelId ] -> + commandSuccess + $ changeFocus (ChannelFocus network channelId) st + _ -> commandFailure st cmdQuit :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -63,30 +63,65 @@ instance Exception ConfigurationFailure -getConfigPath :: IO FilePath -getConfigPath = +-- | Uses 'getAppUserDataDirectory' to find @.glirc/config@ +getOldConfigPath :: IO FilePath +getOldConfigPath = do dir <- getAppUserDataDirectory "glirc" return (dir "config") +-- | Uses 'getXdgDirectory' 'XdgConfig' to find @.config/glirc/config@ +getNewConfigPath :: IO FilePath +getNewConfigPath = + do dir <- getXdgDirectory XdgConfig "glirc" + return (dir "config") + -- | Empty configuration file used when no path is specified -- and the configuration file is missing. emptyConfigFile :: Text emptyConfigFile = "{}\n" +-- | Attempt to read a file using the given handler when +-- a file does not exist. On failure a 'ConfigurationReadFailed' +-- exception is throw. +readFileCatchNotFound :: + FilePath {- ^ file to read -} -> + (IOError -> IO Text) {- ^ error handler for not found case -} -> + IO Text +readFileCatchNotFound path onNotFound = + do res <- try (Text.readFile path) + case res of + Left e | isDoesNotExistError e -> onNotFound e + | otherwise -> throwIO (ConfigurationReadFailed (show e)) + Right txt -> return txt + +-- | Either read a configuration file from one of the default +-- locations, in which case no configuration found is equivalent +-- to an empty configuration, or from the specified file where +-- no configuration found is an error. +readConfigurationFile :: + Maybe FilePath {- ^ just file or use default search paths -} -> + IO Text +readConfigurationFile mbPath = + case mbPath of + + Just path -> + readFileCatchNotFound path $ \e -> + throwIO (ConfigurationReadFailed (show e)) + + Nothing -> + do newPath <- getNewConfigPath + readFileCatchNotFound newPath $ \_ -> + do oldPath <- getOldConfigPath + readFileCatchNotFound oldPath $ \_ -> + return emptyConfigFile + + -- | Load the configuration file defaulting to @~/.glirc/config@. loadConfiguration :: Maybe FilePath {- ^ path to configuration file -} -> IO (Either ConfigurationFailure Configuration) loadConfiguration mbPath = try $ - do path <- maybe getConfigPath return mbPath - fileRes <- try (Text.readFile path) - file <- case fileRes of - Right file -> return file - Left e | isNothing mbPath - , isDoesNotExistError e -> return emptyConfigFile - | otherwise -> - throwIO (ConfigurationReadFailed (show e)) - + do file <- readConfigurationFile mbPath def <- loadDefaultServerSettings rawcfg <- diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -34,13 +34,10 @@ import qualified Data.Map as Map import Data.Maybe import Data.Ord -import qualified Data.Text as Text import Data.Time import Graphics.Vty -import Irc.Identifier import Irc.Message import Irc.RawIrcMsg -import Irc.UserInfo -- | Sum of the three possible event types the event loop handles @@ -240,17 +237,25 @@ KEnd -> changeInput Edit.end KUp -> changeInput $ \ed -> fromMaybe ed $ Edit.earlier ed KDown -> changeInput $ \ed -> fromMaybe ed $ Edit.later ed - KEnter -> execute st KPageUp -> eventLoop (pageUp st) KPageDown -> eventLoop (pageDown st) - KBackTab -> tabCompletion True st - KChar '\t' -> tabCompletion False st + + KEnter -> doCommandResult =<< execute st + KBackTab -> doCommandResult =<< tabCompletion True st + KChar '\t' -> doCommandResult =<< tabCompletion False st + KChar c -> changeInput (Edit.insert c) KFun 2 -> eventLoop (over clientDetailView not st) _ -> eventLoop st _ -> eventLoop st -- unsupported modifier +doCommandResult :: CommandResult -> IO () +doCommandResult res = + case res of + CommandQuit -> return () + CommandContinue st -> eventLoop st + -- | Scroll the current buffer to show older messages pageUp :: ClientState -> ClientState pageUp st = over clientScroll (+ scrollAmount st) st @@ -287,51 +292,6 @@ windows = view clientWindows st (focus,_) = Map.elemAt i windows --- | Respond to the TAB key being pressed. This can dispatch to a command --- specific completion mode when relevant. Otherwise this will complete --- input based on the users of the channel related to the current buffer. -tabCompletion :: Bool {- ^ reversed -} -> ClientState -> IO () -tabCompletion isReversed st = - case clientInput st of - '/':command -> do res <- executeCommand (Just isReversed) command st - case res of - CommandQuit -> return () - CommandContinue st' -> eventLoop st' - _ -> eventLoop (nickTabCompletion isReversed st) - --- | Interpret whatever text is in the textbox. Leading @/@ indicates a --- command. Otherwise if a channel or user query is focused a chat message --- will be sent. -execute :: ClientState -> IO () -execute st = - case clientInput st of - [] -> eventLoop (set clientBell True st) - '/':command -> do res <- executeCommand Nothing command st - case res of - CommandQuit -> return () - CommandContinue st' -> eventLoop st' - msg -> executeChat msg st - --- | Treat the current text input as a chat message and send it. -executeChat :: String -> ClientState -> IO () -executeChat msg st = - case view clientFocus st of - ChannelFocus network channel - | Just cs <- preview (clientConnection network) st -> - do now <- getZonedTime - let msgTxt = Text.pack msg - ircMsg = rawIrcMsg "PRIVMSG" [idText channel, msgTxt] - myNick = UserInfo (view csNick cs) Nothing Nothing - entry = ClientMessage - { _msgTime = now - , _msgNetwork = network - , _msgBody = IrcBody (Privmsg myNick channel msgTxt) - } - sendMsg cs ircMsg - eventLoop $ recordChannelMessage network channel entry - $ consumeInput st - - _ -> eventLoop (set clientBell True st) -- | Respond to a timer event. doTimerEvent :: diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -443,7 +443,7 @@ . set clientSubfocus focus windowNames :: [Char] -windowNames = "1234567890qwertyuiop" +windowNames = "1234567890qwertyuiop!@#$%^&*()QWERTYUIOP" clientMatcher :: ClientState -> Text -> Bool clientMatcher st = diff --git a/src/LensUtils.hs b/src/LensUtils.hs --- a/src/LensUtils.hs +++ b/src/LensUtils.hs @@ -9,8 +9,9 @@ -} module LensUtils - ( Id' - , overStrict + ( + -- * Strict update operations + overStrict , setStrict -- * time lenses @@ -19,26 +20,17 @@ ) where import Control.Lens -import Control.Applicative -import Data.Profunctor.Unsafe import Data.Time - -newtype Id' a = Id' { runId' :: a } - --- | Strict function composition -instance Functor Id' where - fmap = liftA - --- | Strict function application -instance Applicative Id' where - pure = Id' - Id' f <*> Id' x = Id' (f $! x) +import StrictUnit -- | Modify the target of a 'Setter' with a function. The result -- is strict in the results of applying the function. Strict version -- of 'over' -overStrict :: LensLike Id' s t a b -> (a -> b) -> s -> t -overStrict l f = runId' #. l (Id' #. f) +overStrict :: LensLike ((,) StrictUnit) s t a b -> (a -> b) -> s -> t +overStrict l f = run . l (nur . f) + where + nur y = (y `seq` StrictUnit, y) + run (StrictUnit,y) = y {-# INLINE overStrict #-} -- | Set a value strictly in the set value. Strict version of 'set'. @@ -46,8 +38,12 @@ setStrict l x = set l $! x {-# INLINE setStrict #-} +-- | 'Lens' to the 'LocalTime' component of a 'ZonedTime' zonedTimeLocalTime :: Lens' ZonedTime LocalTime zonedTimeLocalTime f (ZonedTime t z) = f t <&> \t' -> ZonedTime t' z +{-# INLINE zonedTimeLocalTime #-} +-- | 'Lens' to the 'TimeOfDay component of a 'LocalTime'. localTimeTimeOfDay :: Lens' LocalTime TimeOfDay localTimeTimeOfDay f (LocalTime d t) = LocalTime d <$> f t +{-# INLINE localTimeTimeOfDay #-} diff --git a/src/StrictUnit.hs b/src/StrictUnit.hs new file mode 100644 --- /dev/null +++ b/src/StrictUnit.hs @@ -0,0 +1,31 @@ +{-| +Module : StrictUnit +Description : Strict unit type +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module provides a unit type where the 'Monoid' and 'Semigroup' +instances are strict in their append operations. This is a helper +module for "LensUtils". + +-} + +module StrictUnit + ( StrictUnit(..) + ) where + +import Data.Semigroup + +-- | Unit data type with a strict 'Semigroup' and 'Monoid' instances. +data StrictUnit = StrictUnit + +-- | '<>' is strict, 'stimes' is /O(1)/ +instance Semigroup StrictUnit where + (<>) = seq + stimes = stimesIdempotent + +-- | 'mappend' is strict +instance Monoid StrictUnit where + mempty = StrictUnit + mappend = (<>)