diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,17 @@ # Revision history for glirc2 +## 2.11 + +* Add `M-S` to jump to previously focused window +* Add `extra-highlights` section +* Tab complete servernames in `/connect` +* Add `/windows` command for listing active windows +* Add `glirc_clear_window` C API procedure +* Allow `process_message` callback to drop messages +* Add optional network and channel arguments to `/clear` (intended to assist macros) +* Automatically reconnect on ping timeout +* Many commands will report message to client window on error + ## 2.10 * Fixes for multiline editing diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -101,6 +101,8 @@ commands: * "extension Lua some-parameter $network $channel" +extra-highlights: ["glirc", "lens"] + palette: time: fg: [10,10,10] -- RGB values for color for timestamps @@ -125,6 +127,7 @@ * `palette` - Client color overrides * `window-names` - text - Names of windows (typically overridden on non QWERTY layouts) * `nick-padding` - nonnegative integer - Nicks are padded until they have the specified length +* `extra-highlights` - list of text - Extra words/nicks to highlight * `extensions` - list of text - Filenames of extension to load Settings @@ -205,7 +208,9 @@ * `/reconnect` - Reconnect to the current server * `/reload` - Reload the previous configuration file (not retroactive!) * `/reload ` - Load a new configuration file +* `/windows` - List all open windows * `/extension ` - Send the given params to the named extension +* `/exec [-n network] [-c channel] ` - Execute a command, If no network or channel are provided send output to client window, if network and channel are provided send output as messages, if network is provided send output as raw IRC messages. Connection commands @@ -216,7 +221,7 @@ * `/focus ` - Change focus to server window * `/focus ` - Change focus to channel window -* `/clear` - Clear contents of current window +* `/clear [network] [channel]` - Clear contents of current or specified window * `/ignore ` - Toggle ignore of a user * `/channel ` - Change focus to channel on current network (alias: `/c`) @@ -282,6 +287,7 @@ * `^P` previous channel * `M-#` jump to window - `1234567890qwertyuiop!@#$%^&*()QWERTYUIOP` * `M-A` jump to activity +* `M-S` jump to previous window * `^A` beginning of line * `^E` end of line * `^K` delete to end diff --git a/exported_symbols.txt b/exported_symbols.txt --- a/exported_symbols.txt +++ b/exported_symbols.txt @@ -6,4 +6,6 @@ glirc_list_channels; glirc_list_channel_users; glirc_my_nick; +glirc_mark_seen; +glirc_clear_window; }; diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,5 +1,5 @@ name: glirc -version: 2.10 +version: 2.11 synopsis: Console IRC client description: Console IRC client license: ISC @@ -27,11 +27,12 @@ executable glirc2 main-is: Main.hs other-modules: Client.CommandArguments - Client.Commands - Client.Commands.Interpolation Client.CApi Client.CApi.Exports Client.CApi.Types + Client.Commands + Client.Commands.Exec + Client.Commands.Interpolation Client.Commands.WordCompletion Client.Configuration Client.Configuration.Colors @@ -48,6 +49,7 @@ Client.Image.Palette Client.Image.StatusLine Client.Image.UserList + Client.Image.Windows Client.Message Client.Network.Async Client.Network.Connect @@ -66,7 +68,7 @@ build-tools: hsc2hs build-depends: base >=4.9 && <4.10, - async >=2.1 && < 2.2, + async >=2.1 && <2.2, attoparsec >=0.13 && <0.14, bytestring >=0.10.8 && <0.11, config-value >=0.5 && <0.6, @@ -78,14 +80,15 @@ filepath >=1.4.1 && <1.5, gitrev >=1.2 && <1.3, hashable >=1.2.4 && <1.3, - irc-core >=2.1 && <2.2, + irc-core >=2.1.1 && <2.2, lens >=4.14 && <4.15, network >=2.6.2 && <2.7, + process >=1.4.2 && <1.5, + regex-tdfa >=1.2 && <1.3, + regex-tdfa-text >=1.0 && <1.1, split >=0.2 && <0.3, stm >=2.4 && <2.5, text >=1.2.2 && <1.3, - regex-tdfa >=1.2 && <1.3, - regex-tdfa-text >=1.0 && <1.1, time >=1.6 && <1.7, tls >=1.3.8 && <1.4, transformers >=0.5.2 && <0.6, diff --git a/src/Client/CApi.hs b/src/Client/CApi.hs --- a/src/Client/CApi.hs +++ b/src/Client/CApi.hs @@ -18,23 +18,18 @@ , deactivateExtension , notifyExtensions , commandExtension - , withStableMVar ) where import Client.CApi.Types -import Control.Concurrent.MVar -import Control.Exception import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Cont -import Data.Foldable import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Foreign as Text import Foreign.C import Foreign.Marshal import Foreign.Ptr -import Foreign.StablePtr import Foreign.Storable import Irc.Identifier import Irc.RawIrcMsg @@ -95,33 +90,38 @@ deactivateExtension stab ae = do let f = fgnStop (aeFgn ae) unless (nullFunPtr == f) $ - (runStopExtension f stab (aeSession ae)) + runStopExtension f stab (aeSession ae) dlclose (aeDL ae) -- | Call all of the process message callbacks in the list of extensions. -- This operation marshals the IRC message once and shares that across -- all of the callbacks. notifyExtensions :: - Ptr () {- ^ clientstate stable pointer -} -> + Ptr () {- ^ clientstate stable pointer -} -> Text {- ^ network -} -> RawIrcMsg {- ^ current message -} -> [ActiveExtension] -> - IO () + IO Bool {- ^ Return 'True' to pass message -} notifyExtensions stab network msg aes - | null aes' = return () - | otherwise = evalContT doNotifications + | null aes' = return True + | otherwise = doNotifications where aes' = [ (f,s) | ae <- aes , let f = fgnMessage (aeFgn ae) s = aeSession ae , f /= nullFunPtr ] - doNotifications :: ContT () IO () doNotifications = - do msgPtr <- withRawIrcMsg network msg - (f,s) <- ContT $ for_ aes' - lift $ runProcessMessage f stab s msgPtr + runContT (withRawIrcMsg network msg) (go aes') + -- run handlers until one of them drops the message + go [] _ = return True + go ((f,s):rest) msgPtr = + do res <- runProcessMessage f stab s msgPtr + if res == passMessage + then go rest msgPtr + else return False + commandExtension :: Ptr () {- ^ client state stableptr -} -> [Text] {- ^ parameters -} -> @@ -132,15 +132,6 @@ let f = fgnCommand (aeFgn ae) lift $ unless (f == nullFunPtr) $ runProcessCommand f stab (aeSession ae) cmd - --- | Create a 'StablePtr' around a 'MVar' which will be valid for the remainder --- of the computation. -withStableMVar :: a -> (Ptr () -> IO b) -> IO (a,b) -withStableMVar x k = - do mvar <- newMVar x - res <- bracket (newStablePtr mvar) freeStablePtr (k . castStablePtrToPtr) - x' <- takeMVar mvar - return (x', res) -- | Marshal a 'RawIrcMsg' into a 'FgnMsg' which will be valid for -- the remainder of the computation. diff --git a/src/Client/CApi/Exports.hs b/src/Client/CApi/Exports.hs --- a/src/Client/CApi/Exports.hs +++ b/src/Client/CApi/Exports.hs @@ -18,13 +18,17 @@ , Glirc_list_channel_users , Glirc_my_nick , Glirc_identifier_cmp + , Glirc_mark_seen + , Glirc_clear_window ) where import Client.CApi.Types import Client.Message import Client.State import Client.State.Channel +import Client.State.Focus import Client.State.Network +import Client.State.Window import Control.Concurrent.MVar import Control.Exception import Control.Lens @@ -41,6 +45,7 @@ import Irc.Identifier import Irc.RawIrcMsg import Irc.UserInfo +import LensUtils ------------------------------------------------------------------------ @@ -89,10 +94,10 @@ Ptr FgnMsg {- ^ pointer to message -} -> IO CInt {- ^ 0 on success -} -foreign export ccall "glirc_send_message" capiSendMessage :: Glirc_send_message +foreign export ccall "glirc_send_message" glirc_send_message :: Glirc_send_message -capiSendMessage :: Glirc_send_message -capiSendMessage token msgPtr = +glirc_send_message :: Glirc_send_message +glirc_send_message token msgPtr = do mvar <- derefToken token fgn <- peek msgPtr msg <- peekFgnMsg fgn @@ -108,7 +113,7 @@ type Glirc_print = Ptr () {- ^ api token -} -> - CInt {- ^ enum message_code -} -> + MessageCode {- ^ enum message_code -} -> CString {- ^ message -} -> CSize {- ^ message length -} -> IO CInt {- ^ 0 on success -} @@ -118,11 +123,11 @@ glirc_print :: Glirc_print glirc_print stab code msgPtr msgLen = do mvar <- derefToken stab - txt <- Text.peekCStringLen (msgPtr, fromIntegral msgLen) + txt <- peekFgnStringLen (FgnStringLen msgPtr msgLen) now <- getZonedTime - let con | code == normalMessageCode = NormalBody - | otherwise = ErrorBody + let con | code == normalMessage = NormalBody + | otherwise = ErrorBody msg = ClientMessage { _msgBody = con txt , _msgTime = now @@ -164,8 +169,8 @@ glirc_identifier_cmp :: Glirc_identifier_cmp glirc_identifier_cmp p1 n1 p2 n2 = - do txt1 <- Text.peekCStringLen (p1, fromIntegral n1) - txt2 <- Text.peekCStringLen (p2, fromIntegral n2) + do txt1 <- peekFgnStringLen (FgnStringLen p1 n1) + txt2 <- peekFgnStringLen (FgnStringLen p2 n2) return $! case compare (mkId txt1) (mkId txt2) of LT -> -1 EQ -> 0 @@ -187,7 +192,7 @@ glirc_list_channels stab networkPtr networkLen = do mvar <- derefToken stab st <- readMVar mvar - network <- Text.peekCStringLen (networkPtr, fromIntegral networkLen) + network <- peekFgnStringLen (FgnStringLen networkPtr networkLen) case preview (clientConnection network . csChannels) st of Nothing -> return nullPtr Just m -> @@ -212,8 +217,8 @@ glirc_list_channel_users stab networkPtr networkLen channelPtr channelLen = do mvar <- derefToken stab st <- readMVar mvar - network <- Text.peekCStringLen (networkPtr, fromIntegral networkLen) - channel <- Text.peekCStringLen (channelPtr, fromIntegral channelLen) + network <- peekFgnStringLen (FgnStringLen networkPtr networkLen) + channel <- peekFgnStringLen (FgnStringLen channelPtr channelLen) let mb = preview ( clientConnection network . csChannels . ix (mkId channel) . chanUsers @@ -240,8 +245,66 @@ glirc_my_nick stab networkPtr networkLen = do mvar <- derefToken stab st <- readMVar mvar - network <- Text.peekCStringLen (networkPtr, fromIntegral networkLen) + network <- peekFgnStringLen (FgnStringLen networkPtr networkLen) let mb = preview (clientConnection network . csNick) st case mb of Nothing -> return nullPtr Just me -> newCString (Text.unpack (idText me)) + +------------------------------------------------------------------------ + +-- | Mark a window as being seen clearing the new message counter. +-- To clear the client window send an empty network name. +-- To clear a network window send an empty channel name. +type Glirc_mark_seen = + Ptr () {- ^ api token -} -> + CString {- ^ network name -} -> + CSize {- ^ network name length -} -> + CString {- ^ channel name -} -> + CSize {- ^ channel name length -} -> + IO () + +foreign export ccall glirc_mark_seen :: Glirc_mark_seen + +glirc_mark_seen :: Glirc_mark_seen +glirc_mark_seen stab networkPtr networkLen channelPtr channelLen = + do network <- peekFgnStringLen (FgnStringLen networkPtr networkLen) + channel <- peekFgnStringLen (FgnStringLen channelPtr channelLen) + + let focus + | Text.null network = Unfocused + | Text.null channel = NetworkFocus network + | otherwise = ChannelFocus network (mkId channel) + + mvar <- derefToken stab + modifyMVar_ mvar $ \st -> + return $! overStrict (clientWindows . ix focus) windowSeen st + +------------------------------------------------------------------------ + +-- | Mark a window as being seen clearing the new message counter. +-- To clear the client window send an empty network name. +-- To clear a network window send an empty channel name. +type Glirc_clear_window = + Ptr () {- ^ api token -} -> + CString {- ^ network name -} -> + CSize {- ^ network name length -} -> + CString {- ^ channel name -} -> + CSize {- ^ channel name length -} -> + IO () + +foreign export ccall glirc_clear_window :: Glirc_clear_window + +glirc_clear_window :: Glirc_clear_window +glirc_clear_window stab networkPtr networkLen channelPtr channelLen = + do network <- peekFgnStringLen (FgnStringLen networkPtr networkLen) + channel <- peekFgnStringLen (FgnStringLen channelPtr channelLen) + + let focus + | Text.null network = Unfocused + | Text.null channel = NetworkFocus network + | otherwise = ChannelFocus network (mkId channel) + + mvar <- derefToken stab + modifyMVar_ mvar $ \st -> + return $! set (clientWindows . ix focus) emptyWindow st diff --git a/src/Client/CApi/Types.hsc b/src/Client/CApi/Types.hsc --- a/src/Client/CApi/Types.hsc +++ b/src/Client/CApi/Types.hsc @@ -38,19 +38,21 @@ , runProcessCommand -- * report message codes - , normalMessageCode - , errorMessageCode + , MessageCode(..), normalMessage, errorMessage + + -- * process message results + , MessageResult(..), passMessage, dropMessage ) where import Foreign.C import Foreign.Ptr import Foreign.Storable -normalMessageCode :: CInt -normalMessageCode = #const NORMAL_MESSAGE +newtype MessageCode = MessageCode CInt deriving Eq +#enum MessageCode, MessageCode, NORMAL_MESSAGE, ERROR_MESSAGE -errorMessageCode :: CInt -errorMessageCode = #const ERROR_MESSAGE +newtype MessageResult = MessageResult CInt deriving Eq +#enum MessageResult, MessageResult, PASS_MESSAGE, DROP_MESSAGE type StartExtension = Ptr () {- ^ api token -} -> @@ -66,7 +68,7 @@ Ptr () {- ^ api token -} -> Ptr () {- ^ extention state -} -> Ptr FgnMsg {- ^ message to send -} -> - IO () + IO MessageResult type ProcessCommand = Ptr () {- ^ api token -} -> diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -19,6 +19,7 @@ ) where import Client.CApi +import Client.Commands.Exec import Client.Commands.Interpolation import Client.Commands.WordCompletion import Client.Configuration @@ -67,7 +68,6 @@ -- | Type of commands that require an active network to be focused type NetworkCommand = - Text {- ^ focused network -} -> NetworkState {- ^ focused connection state -} -> ClientState -> String {- ^ command arguments -} -> @@ -75,7 +75,6 @@ -- | Type of commands that require an active channel to be focused type ChannelCommand = - Text {- ^ focused network -} -> NetworkState {- ^ focused connection state -} -> Identifier {- ^ focused channel -} -> ClientState -> @@ -99,6 +98,12 @@ commandFailure :: Monad m => ClientState -> m CommandResult commandFailure = return . CommandFailure +-- | Command failure with an error message printed to client window +commandFailureMsg :: Text -> ClientState -> IO CommandResult +commandFailureMsg e st = + do now <- getZonedTime + return $! CommandFailure $! recordError now st e + -- | Interpret the given chat message or command. Leading @/@ indicates a -- command. Otherwise if a channel or user query is focused a chat message -- will be sent. @@ -120,7 +125,7 @@ Nothing -> executeCommand Nothing command st Just cmdExs -> case traverse (resolveExpansions expandVar expandInt) cmdExs of - Nothing -> commandFailure st + Nothing -> commandFailureMsg "Macro expansions failed" st Just cmds -> process cmds st where args = Text.words (Text.pack command) @@ -171,7 +176,7 @@ sendMsg cs ircMsg commandSuccess $ recordChannelMessage network channel entry st - _ -> commandFailure st + _ -> commandFailureMsg "This command requires an active channel" st splitWord :: String -> (String, String) splitWord str = (w, drop 1 rest) @@ -197,6 +202,11 @@ cmdTxt = Text.toLower (Text.pack cmd) in case HashMap.lookup cmdTxt commands of + Nothing -> + case tabCompleteReversed of + Nothing -> commandFailureMsg "Unknown command" st + Just isReversed -> commandSuccess (nickTabCompletion isReversed st) + Just (ClientCommand exec tab) -> maybe exec tab tabCompleteReversed st rest @@ -205,24 +215,23 @@ | Just network <- views clientFocus focusNetwork st , Just cs <- preview (clientConnection network) st -> maybe exec tab tabCompleteReversed - network cs st rest + cs st rest + | 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 - network cs channelId st rest + cs channelId st rest + | 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 - network cs channelId st rest - - _ -> case tabCompleteReversed of - Nothing -> commandFailure st - Just isReversed -> commandSuccess (nickTabCompletion isReversed st) + cs channelId st rest + | 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)] @@ -231,7 +240,7 @@ commands :: HashMap Text Command commands = HashMap.fromList $ expandAliases - [ (["connect" ], ClientCommand cmdConnect noClientTab) + [ (["connect" ], ClientCommand cmdConnect tabConnect) , (["exit" ], ClientCommand cmdExit noClientTab) , (["focus" ], ClientCommand cmdFocus tabFocus) , (["clear" ], ClientCommand cmdClear noClientTab) @@ -239,6 +248,8 @@ , (["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) @@ -281,21 +292,21 @@ noClientTab _ st _ = commandFailure st noNetworkTab :: Bool -> NetworkCommand -noNetworkTab _ _ _ st _ = commandFailure st +noNetworkTab _ _ st _ = commandFailure st noChannelTab :: Bool -> ChannelCommand -noChannelTab _ _ _ _ st _ = commandFailure st +noChannelTab _ _ _ st _ = commandFailure st simpleClientTab :: Bool -> ClientCommand simpleClientTab isReversed st _ = commandSuccess (nickTabCompletion isReversed st) simpleNetworkTab :: Bool -> NetworkCommand -simpleNetworkTab isReversed _ _ st _ = +simpleNetworkTab isReversed _ st _ = commandSuccess (nickTabCompletion isReversed st) simpleChannelTab :: Bool -> ChannelCommand -simpleChannelTab isReversed _ _ _ st _ = +simpleChannelTab isReversed _ _ st _ = commandSuccess (nickTabCompletion isReversed st) cmdExit :: ClientCommand @@ -306,41 +317,48 @@ -- 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 _ = commandSuccess (windowEffect st) +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 where - windowEffect - | isActive = clearWindow - | otherwise = deleteWindow + clearFocus focus = commandSuccess (windowEffect st) + where + windowEffect + | isActive = clearWindow + | otherwise = deleteWindow - deleteWindow = advanceFocus . setWindow Nothing - clearWindow = setWindow (Just emptyWindow) + deleteWindow = advanceFocus . setWindow Nothing + clearWindow = setWindow (Just emptyWindow) - setWindow = set (clientWindows . at (view clientFocus st)) + setWindow = set (clientWindows . at (view clientFocus st)) - isActive = - case view clientFocus st of - Unfocused -> False - NetworkFocus network -> - has (clientConnection network) st - ChannelFocus network channel -> - has ( clientConnection network - . csChannels . ix channel) st + isActive = + case focus of + Unfocused -> False + NetworkFocus network -> has (clientConnection network) st + ChannelFocus network channel -> has (clientConnection network + .csChannels . ix channel) st cmdQuote :: NetworkCommand -cmdQuote _ cs st rest = +cmdQuote cs st rest = case parseRawIrcMsg (Text.pack rest) of - Nothing -> commandFailure st + Nothing -> commandFailureMsg "Failed to parse IRC command" st Just raw -> do sendMsg cs raw commandSuccess st -- | Implementation of @/me@ cmdMe :: ChannelCommand -cmdMe network cs channelId st rest = +cmdMe cs channelId st rest = do now <- getZonedTime let actionTxt = Text.pack ("\^AACTION " ++ rest ++ "\^A") !myNick = UserInfo (view csNick cs) "" "" + network = view csNetwork cs entry = ClientMessage { _msgTime = now , _msgNetwork = network @@ -352,9 +370,9 @@ -- | Implementation of @/ctcp@ cmdCtcp :: NetworkCommand -cmdCtcp network cs st rest = +cmdCtcp cs st rest = case parse of - Nothing -> commandFailure st + Nothing -> commandFailureMsg "Usage: /ctcp TARGET COMMAND ARGS" st Just (target, cmd, args) -> do let cmdTxt = Text.toUpper (Text.pack cmd) argTxt = Text.pack args @@ -363,8 +381,7 @@ sendMsg cs (ircPrivmsg (mkId tgtTxt) ("\^A" <> cmdTxt <> " " <> argTxt <> "\^A")) chatCommand (\src tgt -> Ctcp src tgt cmdTxt argTxt) - tgtTxt - network cs st + tgtTxt cs st where parse = do (target, rest1) <- nextWord rest @@ -373,47 +390,56 @@ -- | Implementation of @/notice@ cmdNotice :: NetworkCommand -cmdNotice network cs st rest = +cmdNotice cs st rest = case nextWord rest of - Nothing -> commandFailure st - Just (target, rest1) -> + Just (target, rest1) | not (null rest1) -> do let restTxt = Text.pack rest1 tgtTxt = Text.pack target sendMsg cs (ircNotice (mkId tgtTxt) restTxt) chatCommand (\src tgt -> Notice src tgt restTxt) - tgtTxt - network cs st + tgtTxt cs st + _ -> commandFailureMsg "Usage: /notice TARGET MESSAGE" st + -- | Implementation of @/msg@ cmdMsg :: NetworkCommand -cmdMsg network cs st rest = +cmdMsg cs st rest = case nextWord rest of - Nothing -> commandFailure st - Just (target, rest1) -> + Just (target, rest1) | not (null rest1) -> do let restTxt = Text.pack rest1 tgtTxt = Text.pack target sendMsg cs (ircPrivmsg (mkId tgtTxt) restTxt) chatCommand (\src tgt -> Privmsg src tgt restTxt) - tgtTxt - network cs st + tgtTxt cs st + _ -> commandFailureMsg "Usage: /msg TARGET MESSAGE" st -- | Common logic for @/msg@ and @/notice@ chatCommand :: (UserInfo -> Identifier -> IrcMsg) -> Text {- ^ target -} -> - Text {- ^ network -} -> NetworkState -> ClientState -> IO CommandResult -chatCommand con targetsTxt network cs st = +chatCommand mkmsg target cs st = + commandSuccess =<< chatCommand' mkmsg target cs st + +-- | Common logic for @/msg@ and @/notice@ returning the client state +chatCommand' :: + (UserInfo -> Identifier -> IrcMsg) -> + Text {- ^ target -} -> + NetworkState -> + ClientState -> + IO ClientState +chatCommand' con targetsTxt cs st = do now <- getZonedTime let targetTxts = Text.split (==',') targetsTxt targetIds = mkId <$> targetTxts !myNick = UserInfo (view csNick cs) "" "" + network = view csNetwork cs entries = [ (targetId, ClientMessage { _msgTime = now @@ -422,12 +448,11 @@ }) | targetId <- targetIds ] - st' = foldl' (\acc (targetId, entry) -> - recordChannelMessage network targetId entry acc) - st - entries + return $! foldl' (\acc (targetId, entry) -> + recordChannelMessage network targetId entry acc) + st + entries - commandSuccess st' cmdConnect :: ClientCommand cmdConnect st rest = @@ -439,11 +464,14 @@ commandSuccess $ changeFocus (NetworkFocus network) st' - _ -> commandFailure 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) @@ -453,8 +481,23 @@ commandSuccess $ changeFocus focus st - _ -> commandFailure st + _ -> commandFailureMsg "Focus requires a network and an optional channel" st +-- | Implementation of @/windows@ command. Set subfocus to Windows. +cmdWindows :: ClientCommand +cmdWindows st _rest = commandSuccess (changeSubfocus FocusWindows st) + + +-- | @/connect@ tab completes known server names +tabConnect :: Bool -> ClientCommand +tabConnect isReversed st _ + = commandSuccess + $ fromMaybe st + $ clientTextBox (wordComplete id isReversed [] networks) st + where + networks = HashMap.keys $ view clientNetworkMap st + + -- | When tab completing the first parameter of the focus command -- the current networks are used. tabFocus :: Bool -> ClientCommand @@ -471,58 +514,58 @@ | otherwise = currentCompletionList st cmdWhois :: NetworkCommand -cmdWhois _ cs st rest = +cmdWhois cs st rest = do sendMsg cs (ircWhois (Text.pack <$> words rest)) commandSuccess st cmdWho :: NetworkCommand -cmdWho _ cs st rest = +cmdWho cs st rest = do sendMsg cs (ircWho (Text.pack <$> words rest)) commandSuccess st cmdWhowas :: NetworkCommand -cmdWhowas _ cs st rest = +cmdWhowas cs st rest = do sendMsg cs (ircWhowas (Text.pack <$> words rest)) commandSuccess st cmdIson :: NetworkCommand -cmdIson _ cs st rest = +cmdIson cs st rest = do sendMsg cs (ircIson (Text.pack <$> words rest)) commandSuccess st cmdUserhost :: NetworkCommand -cmdUserhost _ cs st rest = +cmdUserhost cs st rest = do sendMsg cs (ircUserhost (Text.pack <$> words rest)) commandSuccess st cmdStats :: NetworkCommand -cmdStats _ cs st rest = +cmdStats cs st rest = do sendMsg cs (ircStats (Text.pack <$> words rest)) commandSuccess st cmdAway :: NetworkCommand -cmdAway _ cs st rest = - do sendMsg cs (ircAway (Text.pack (dropWhile (==' ') rest))) +cmdAway cs st rest = + do sendMsg cs (ircAway (Text.pack rest)) commandSuccess st cmdLinks :: NetworkCommand -cmdLinks _ cs st rest = +cmdLinks cs st rest = do sendMsg cs (ircLinks (Text.pack <$> words rest)) commandSuccess st cmdTime :: NetworkCommand -cmdTime _ cs st rest = +cmdTime cs st rest = do sendMsg cs (ircTime (Text.pack <$> words rest)) commandSuccess st cmdZnc :: NetworkCommand -cmdZnc _ cs st rest = +cmdZnc cs st rest = do sendMsg cs (ircZnc (Text.words (Text.pack rest))) commandSuccess st -- TODO: support time ranges cmdZncPlayback :: NetworkCommand -cmdZncPlayback _ cs st rest = +cmdZncPlayback cs st rest = case words rest of -- request everything @@ -546,7 +589,7 @@ { localTimeOfDay = tod , localDay = day } } - _ -> commandFailure st + _ -> commandFailureMsg "Unable to parse date/time arguments" st where -- %k doesn't require a leading 0 for times before 10AM @@ -562,29 +605,29 @@ commandSuccess st cmdMode :: NetworkCommand -cmdMode _ cs st rest = modeCommand (Text.pack <$> words rest) cs st +cmdMode cs st rest = modeCommand (Text.pack <$> words rest) cs st cmdNick :: NetworkCommand -cmdNick _ cs st rest = +cmdNick cs st rest = case words rest of [nick] -> do sendMsg cs (ircNick (mkId (Text.pack nick))) commandSuccess st - _ -> commandFailure st + _ -> commandFailureMsg "Usage: /nick NICK" st cmdPart :: ChannelCommand -cmdPart _ cs channelId st rest = - do let msg = dropWhile isSpace rest +cmdPart cs channelId 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 _network _cs _channelId st rest = executeChat rest st +cmdSay _cs _channelId st rest = executeChat rest st cmdInvite :: ChannelCommand -cmdInvite _ cs channelId st rest = +cmdInvite cs channelId st rest = case words rest of [nick] -> do let freeTarget = has (csChannels . ix channelId . chanModes . ix 'g') cs @@ -594,7 +637,7 @@ else sendModeration channelId [cmd] cs commandSuccessUpdateCS cs' st - _ -> commandFailure st + _ -> commandFailureMsg "Usage: /invite NICK" st commandSuccessUpdateCS :: NetworkState -> ClientState -> IO CommandResult commandSuccessUpdateCS cs st = @@ -603,12 +646,12 @@ $ setStrict (clientConnections . ix networkId) cs st cmdTopic :: ChannelCommand -cmdTopic _ cs channelId st rest = +cmdTopic cs channelId st rest = do let cmd = - case dropWhile isSpace rest of + case rest of "" -> ircTopic channelId "" topic | useChanServ channelId cs -> - ircPrivmsg (mkId "ChanServ") + ircPrivmsg "ChanServ" ("TOPIC " <> idText channelId <> Text.pack (' ' : topic)) | otherwise -> ircTopic channelId (Text.pack topic) sendMsg cs cmd @@ -617,7 +660,7 @@ tabTopic :: Bool {- ^ reversed -} -> ChannelCommand -tabTopic _ _ cs channelId st rest +tabTopic _ cs channelId st rest | all isSpace rest , Just topic <- preview (csChannels . ix channelId . chanTopic) cs = @@ -628,35 +671,35 @@ cmdUsers :: ChannelCommand -cmdUsers _ _ _ st _ = commandSuccess (changeSubfocus FocusUsers st) +cmdUsers _ _ st _ = commandSuccess (changeSubfocus FocusUsers st) cmdChannelInfo :: ChannelCommand -cmdChannelInfo _ _ _ st _ = commandSuccess (changeSubfocus FocusInfo st) +cmdChannelInfo _ _ st _ = commandSuccess (changeSubfocus FocusInfo st) cmdMasks :: ChannelCommand -cmdMasks _ cs _ st rest = +cmdMasks cs _ st rest = case words rest of [[mode]] | mode `elem` view (csModeTypes . modesLists) cs -> commandSuccess (changeSubfocus (FocusMasks mode) st) - _ -> commandFailure st + _ -> commandFailureMsg "Unknown mask mode" st cmdKick :: ChannelCommand -cmdKick _ cs channelId st rest = +cmdKick cs channelId st rest = case nextWord rest of - Nothing -> commandFailure st + Nothing -> commandFailureMsg "Usage: /kick NICK [MESSAGE]" st Just (who,reason) -> - do let msg = Text.pack (dropWhile isSpace 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 = +cmdKickBan cs channelId st rest = case nextWord rest of - Nothing -> commandFailure st + Nothing -> commandFailureMsg "Usage: /kickban NICK [MESSAGE]" st Just (whoStr,reason) -> - do let msg = Text.pack (dropWhile isSpace reason) + do let msg = Text.pack reason whoTxt = Text.pack whoStr @@ -670,22 +713,23 @@ computeBanUserInfo :: Identifier -> NetworkState -> UserInfo computeBanUserInfo who cs = case view (csUser who) cs of - Nothing -> UserInfo who "*" "*" - Just (UserAndHost _ host) -> UserInfo (mkId "*") "*" host + Nothing -> UserInfo who "*" "*" + Just (UserAndHost _ host) -> UserInfo "*" "*" host cmdRemove :: ChannelCommand -cmdRemove _ cs channelId st rest = +cmdRemove cs channelId st rest = case nextWord rest of - Nothing -> commandFailure st + Nothing -> commandFailureMsg "Usage: /remove NICK [MESSAGE]" st Just (who,reason) -> - do let msg = Text.pack (dropWhile isSpace 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 network cs st rest = +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)) @@ -694,29 +738,29 @@ in case ws of [channel] -> doJoin channel Nothing [channel,key] -> doJoin channel (Just key) - _ -> commandFailure st + _ -> commandFailureMsg "Usage: /join CHANNELS [KEYS]" 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 = +cmdChannel cs st rest = case mkId . Text.pack <$> words rest of [ channelId ] -> commandSuccess - $ changeFocus (ChannelFocus network channelId) st - _ -> commandFailure st + $ changeFocus (ChannelFocus (view csNetwork cs) channelId) st + _ -> commandFailureMsg "Usage: /channel CHANNEL" st cmdQuit :: NetworkCommand -cmdQuit _ cs st rest = - do let msg = Text.pack (dropWhile isSpace rest) +cmdQuit cs st rest = + do let msg = Text.pack rest sendMsg cs (ircQuit msg) commandSuccess st cmdDisconnect :: NetworkCommand -cmdDisconnect network _ st _ = - do st' <- abortNetwork network st +cmdDisconnect cs st _ = + do st' <- abortNetwork (view csNetwork cs) st commandSuccess st' -- | Reconnect to the currently focused network. It's possible @@ -730,7 +774,7 @@ commandSuccess $ changeFocus (NetworkFocus network) st' - | otherwise = commandFailure st + | otherwise = commandFailureMsg "/reconnect requires focused network" st cmdIgnore :: ClientCommand cmdIgnore st rest = @@ -752,11 +796,19 @@ | otherwise = Just rest res <- loadConfiguration path case res of - Left{} -> commandFailure st + Left e -> commandFailureMsg (describeProblem e) st Right cfg -> do st1 <- clientStartExtensions (set clientConfig cfg st) commandSuccess st1 + where + describeProblem err = + Text.pack $ + case err of + ConfigurationReadFailed e -> "Failed to open configuration:" ++ e + ConfigurationParseFailed e -> "Failed to parse configuration:" ++ e + ConfigurationMalformed e -> "Configuration malformed: " ++ e + -- | Support file name tab completion when providing an alternative -- configuration file. -- @@ -781,7 +833,7 @@ [] -> success False [[]] flags:params -> case splitModes (view csModeTypes cs) flags params of - Nothing -> commandFailure st + Nothing -> commandFailureMsg "Failed to parse modes" st Just parsedModes -> success needOp (unsplitModes <$> chunksOf (view csModeCount cs) parsedModes') where @@ -804,7 +856,7 @@ _ -> commandFailure st tabMode :: Bool -> NetworkCommand -tabMode isReversed _ cs st rest = +tabMode isReversed cs st rest = case view clientFocus st of ChannelFocus _ channel @@ -885,7 +937,7 @@ n = length leadingPart (cursorPos, line) = clientLine st leadingPart = takeWhile (not . isSpace) line - possibilities = mkId . Text.cons '/' <$> commandNames + possibilities = Text.cons '/' <$> commandNames commandNames = HashMap.keys commands ++ HashMap.keys (view (clientConfig . configMacros) st) @@ -910,7 +962,7 @@ IO NetworkState sendModeration channel cmds cs | useChanServ channel cs = - do sendMsg cs (ircPrivmsg (mkId "ChanServ") ("OP " <> idText channel)) + do sendMsg cs (ircPrivmsg "ChanServ" ("OP " <> idText channel)) return $ csChannels . ix channel . chanQueuedModeration <>~ cmds $ cs | otherwise = cs <$ traverse_ (sendMsg cs) cmds @@ -922,10 +974,89 @@ cmdExtension :: ClientCommand cmdExtension st rest = case Text.words (Text.pack rest) of - name:params - | Just ae <- find (\ae -> aeName ae == name) (view clientExtensions st) -> - do (st',_) <- withStableMVar st $ \stab -> - commandExtension stab params ae - commandSuccess st' - _ -> commandFailure st + name:params -> + case find (\ae -> aeName ae == name) + (view (clientExtensions . esActive) st) of + Nothing -> commandFailureMsg "Unknown extension" st + Just ae -> + do (st',_) <- clientPark st $ \ptr -> + commandExtension ptr params ae + commandSuccess st' + _ -> commandFailureMsg "Usage: /extension EXTENSION ARGUMENTS" st +-- | Implementation of @/exec@ command. +cmdExec :: ClientCommand +cmdExec st rest = + do now <- getZonedTime + case parseExecCmd rest of + Left es -> failure now es + Right ec -> + case buildTransmitter now ec of + Left es -> failure now es + Right tx -> + do res <- runExecCmd ec + case res of + Left es -> failure now es + Right msgs -> tx (map Text.pack msgs) + + where + buildTransmitter now ec = + case (Text.pack <$> view execOutputNetwork ec, + Text.pack <$> view execOutputChannel ec) of + (Nothing, Nothing) -> Right (sendToClient now) + (Just network, Nothing) -> + case preview (clientConnection network) st of + Nothing -> Left ["Unknown network"] + Just cs -> Right (sendToNetwork now cs) + (Nothing , Just channel) -> + case currentNetworkState of + Nothing -> Left ["No current network"] + Just cs -> Right (sendToChannel cs channel) + (Just network, Just channel) -> + case preview (clientConnection network) st of + Nothing -> Left ["Unknown network"] + Just cs -> Right (sendToChannel cs channel) + + sendToClient now msgs = commandSuccess $! foldl' (recordSuccess now) st msgs + + sendToNetwork now cs msgs = + commandSuccess =<< + foldM (\st1 msg -> + case parseRawIrcMsg msg of + Nothing -> + return $! recordError now st1 ("Bad raw message: " <> msg) + Just raw -> + do sendMsg cs raw + return st1) st msgs + + sendToChannel cs channel msgs = + commandSuccess =<< + foldM (\st1 msg -> + do sendMsg cs (ircPrivmsg (mkId channel) msg) + chatCommand' + (\src tgt -> Privmsg src tgt msg) + channel + cs st1) st (filter (not . Text.null) msgs) + + currentNetworkState = + do network <- views clientFocus focusNetwork st + preview (clientConnection network) st + + failure now es = + commandFailure $! foldl' (recordError now) st (map Text.pack es) + +recordError :: ZonedTime -> ClientState -> Text -> ClientState +recordError now ste e = + recordNetworkMessage ClientMessage + { _msgTime = now + , _msgBody = ErrorBody e + , _msgNetwork = "" + } ste + +recordSuccess :: ZonedTime -> ClientState -> Text -> ClientState +recordSuccess now ste m = + recordNetworkMessage ClientMessage + { _msgTime = now + , _msgBody = NormalBody m + , _msgNetwork = "" + } ste diff --git a/src/Client/Commands/Exec.hs b/src/Client/Commands/Exec.hs new file mode 100644 --- /dev/null +++ b/src/Client/Commands/Exec.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE TemplateHaskell, BangPatterns, OverloadedStrings #-} + +{-| +Module : Client.Commands +Description : Implementation of slash commands +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module renders the lines used in the channel mask list. A mask list +can show channel bans, quiets, invites, and exceptions. +-} + +module Client.Commands.Exec where + +import Control.Exception +import Control.Lens +import System.Console.GetOpt +import System.Process + +data ExecCmd = ExecCmd + { _execOutputNetwork :: Maybe String + , _execOutputChannel :: Maybe String + , _execCommand :: String + , _execStdIn :: String + , _execArguments :: [String] + } + deriving (Read,Show) + +makeLenses ''ExecCmd + +emptyExecCmd :: ExecCmd +emptyExecCmd = ExecCmd + { _execOutputNetwork = Nothing + , _execOutputChannel = Nothing + , _execCommand = error "no default command" + , _execStdIn = "" + , _execArguments = [] + } + +options :: [OptDescr (ExecCmd -> ExecCmd)] +options = + [ Option "n" ["network"] + (ReqArg (set execOutputNetwork . Just) "NETWORK") + "Set network target" + , Option "c" ["channel"] + (ReqArg (set execOutputChannel . Just) "CHANNEL") + "Set channel target" + , Option "i" ["input"] + (ReqArg (set execStdIn) "INPUT") + "Use string as stdin" + ] + +-- TODO: support quoted strings +parseExecCmd :: String -> Either [String] ExecCmd +parseExecCmd str = + case getOpt RequireOrder options (words str) of + (_, [] , errs) -> Left ("No command specified":errs) + (fs, cmd:args, []) -> Right + $ foldl (\x f -> f x) ?? fs + $ set execCommand cmd + $ set execArguments args + $ emptyExecCmd + (_,_, errs) -> Left errs + +runExecCmd :: ExecCmd -> IO (Either [String] [String]) +runExecCmd e = + do res <- try (readProcess (view execCommand e) + (view execArguments e) + (view execStdIn e)) + return $ case res of + Left er -> Left [show (er :: IOError)] + Right x -> Right (lines x) diff --git a/src/Client/Commands/WordCompletion.hs b/src/Client/Commands/WordCompletion.hs --- a/src/Client/Commands/WordCompletion.hs +++ b/src/Client/Commands/WordCompletion.hs @@ -19,6 +19,7 @@ import Data.Char import Data.List import qualified Data.Set as Set +import Data.String (IsString(..)) import qualified Data.Text as Text import Data.Text (Text) import Irc.Identifier @@ -34,29 +35,30 @@ -- will be considered in order before resorting to the set of possible -- completions. wordComplete :: + Prefix a => (String -> String) {- ^ leading update operation -} -> Bool {- ^ reversed -} -> - [Identifier] {- ^ priority completions -} -> - [Identifier] {- ^ possible completions -} -> + [a] {- ^ priority completions -} -> + [a] {- ^ possible completions -} -> Edit.EditBox -> Maybe Edit.EditBox wordComplete leadingCase isReversed hint vals box = do let current = currentWord box guard (not (null current)) - let cur = mkId (Text.pack current) + let cur = fromString current case view Edit.lastOperation box of Edit.TabOperation patternStr - | idPrefix pat cur -> + | isPrefix pat cur -> do next <- tabSearch isReversed pat cur vals - Just $ replaceWith leadingCase (idString next) box + Just $ replaceWith leadingCase (toString next) box where - pat = mkId (Text.pack patternStr) + pat = fromString patternStr _ -> - do next <- find (idPrefix cur) hint <|> + do next <- find (isPrefix cur) hint <|> tabSearch isReversed cur cur vals Just $ set Edit.lastOperation (Edit.TabOperation current) - $ replaceWith leadingCase (idString next) box + $ replaceWith leadingCase (toString next) box replaceWith :: (String -> String) -> String -> Edit.EditBox -> Edit.EditBox replaceWith leadingCase str box = @@ -65,9 +67,6 @@ | otherwise = str in over Edit.content (Edit.insertString str1) box1 -idString :: Identifier -> String -idString = Text.unpack . idText - currentWord :: Edit.EditBox -> String currentWord box = reverse @@ -77,12 +76,19 @@ $ take n txt where Edit.Line n txt = view Edit.line box -class Prefix a where isPrefix :: a -> a -> Bool -instance Prefix Identifier where isPrefix = idPrefix -instance Prefix Text where isPrefix = Text.isPrefixOf -instance Eq a => Prefix [a] where isPrefix = isPrefixOf +class (IsString a, Ord a) => Prefix a where + isPrefix :: a -> a -> Bool + toString :: a -> String -tabSearch :: (Ord a, Prefix a) => Bool -> a -> a -> [a] -> Maybe a +instance Prefix Identifier where + isPrefix = idPrefix + toString = Text.unpack . idText + +instance Prefix Text where + isPrefix = Text.isPrefixOf + toString = Text.unpack + +tabSearch :: Prefix a => Bool -> a -> a -> [a] -> Maybe a tabSearch isReversed pat cur vals | Just next <- advanceFun cur valSet , isPrefix pat next diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -26,6 +26,7 @@ , configConfigPath , configMacros , configExtensions + , configExtraHighlights -- * Loading configuration , loadConfiguration @@ -46,6 +47,8 @@ import Data.Foldable (for_) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet import Data.Maybe import Data.Text (Text) import qualified Data.Text as Text @@ -60,15 +63,16 @@ -- server configuration from '_configServers' is used where possible, -- otherwise '_configDefaults' is used. data Configuration = Configuration - { _configDefaults :: ServerSettings -- ^ Default connection settings - , _configServers :: (HashMap Text ServerSettings) -- ^ Host-specific settings - , _configPalette :: Palette - , _configWindowNames :: Text -- ^ Names of windows, used when alt-jumping) - , _configNickPadding :: Maybe Integer -- ^ Padding of nicks - , _configConfigPath :: Maybe FilePath + { _configDefaults :: ServerSettings -- ^ Default connection settings + , _configServers :: (HashMap Text ServerSettings) -- ^ Host-specific settings + , _configPalette :: Palette + , _configWindowNames :: Text -- ^ Names of windows, used when alt-jumping) + , _configExtraHighlights :: HashSet Identifier -- ^ Extra highlight nicks/terms + , _configNickPadding :: Maybe Integer -- ^ Padding of nicks + , _configConfigPath :: Maybe FilePath -- ^ manually specified configuration path, used for reloading - , _configMacros :: HashMap Text [[ExpansionChunk]] -- ^ command macros - , _configExtensions :: [FilePath] -- ^ paths to shared library + , _configMacros :: HashMap Text [[ExpansionChunk]] -- ^ command macros + , _configExtensions :: [FilePath] -- ^ paths to shared library } deriving Show @@ -180,6 +184,9 @@ _configExtensions <- fromMaybe [] <$> sectionOptWith (parseList parseString) "extensions" + + _configExtraHighlights <- maybe HashSet.empty HashSet.fromList + <$> sectionOptWith (parseList parseIdentifier) "extra-highlights" _configNickPadding <- sectionOpt "nick-padding" for_ _configNickPadding (\padding -> diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -1,4 +1,4 @@ -{-# Language OverloadedStrings #-} +{-# Language OverloadedStrings, NondecreasingIndentation #-} {-| Module : Client.EventLoop @@ -43,6 +43,7 @@ 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 Graphics.Vty import Irc.Codes import Irc.Message @@ -138,15 +139,25 @@ SomeException {- ^ termination reason -} -> ClientState -> IO () doNetworkError networkId time ex st = - let (cs,st') = removeNetwork networkId st - msg = ClientMessage - { _msgTime = time - , _msgNetwork = view csNetwork cs - , _msgBody = ErrorBody (Text.pack (show ex)) - } - in eventLoop $ recordNetworkMessage msg st' + do let (cs,st1) = removeNetwork networkId st + msg = ClientMessage + { _msgTime = time + , _msgNetwork = view csNetwork cs + , _msgBody = ErrorBody (Text.pack (displayException ex)) + } + shouldReconnect + | Just PingTimeout <- fromException ex = True + | Just ResourceVanished <- ioe_type <$> fromException ex = True + | otherwise = False + nextAction + | shouldReconnect = addConnection (view csNetwork cs) + | otherwise = return + + eventLoop =<< nextAction (recordNetworkMessage msg st1) + + -- | Respond to an IRC protocol line. This will parse the message, updated the -- relevant connection state and update the UI buffers. doNetworkLine :: @@ -170,8 +181,13 @@ eventLoop (recordNetworkMessage msg st) Just raw -> - do (st1,_) <- withStableMVar st $ \ptr -> - notifyExtensions ptr network raw (view clientExtensions st) + do (st1,passed) <- clientPark st $ \ptr -> + notifyExtensions ptr network raw + (view (clientExtensions . esActive) st) + + + if not passed then eventLoop st1 else do + let time' = computeEffectiveTime time (view msgTags raw) (stateHook, viewHook) @@ -206,7 +222,7 @@ -- | Client-level responses to specific IRC messages. -- This is in contrast to the connection state tracking logic in -- "Client.NetworkState " -clientResponse :: ZonedTime -> IrcMsg -> NetworkState -> ClientState -> IO ClientState +clientResponse :: ZonedTime -> IrcMsg -> NetworkState -> ClientState -> IO ClientState clientResponse now irc cs st = case irc of Reply RPL_WELCOME _ -> @@ -277,7 +293,7 @@ $ set clientHeight h st EvPaste utf8 -> let str = Text.unpack (Text.decodeUtf8With Text.lenientDecode utf8) - st' = over (clientTextBox . Edit.content) (Edit.insertString str) st + st' = over clientTextBox (Edit.insertPaste str) st in eventLoop st' _ -> eventLoop st @@ -298,7 +314,7 @@ KChar 'e' -> changeEditor Edit.end KChar 'u' -> changeEditor Edit.killHome KChar 'k' -> changeEditor Edit.killEnd - KChar 'y' -> changeEditor Edit.paste + KChar 'y' -> changeEditor Edit.yank KChar 'w' -> changeEditor (Edit.killWordBackward True) KChar 'b' -> changeEditor (Edit.insert '\^B') KChar 'c' -> changeEditor (Edit.insert '\^C') @@ -319,6 +335,7 @@ KChar 'b' -> changeContent Edit.leftWord KChar 'f' -> changeContent Edit.rightWord KChar 'a' -> eventLoop (jumpToActivity st) + KChar 's' -> eventLoop (returnFocus st) KChar c | let names = view (clientConfig . configWindowNames) st , Just i <- Text.findIndex (==c) names -> eventLoop (jumpFocus i st) diff --git a/src/Client/Hook/Znc/Buffextras.hs b/src/Client/Hook/Znc/Buffextras.hs --- a/src/Client/Hook/Znc/Buffextras.hs +++ b/src/Client/Hook/Znc/Buffextras.hs @@ -37,11 +37,11 @@ Bool {- ^ enable debugging -} -> IrcMsg -> MessageResult remap debug (Privmsg user chan msg) - | userNick user == mkId "*buffextras" + | userNick user == "*buffextras" , Right newMsg <- parseOnly (prefixedParser chan) msg = RemapMessage newMsg - | userNick user == mkId "*buffextras" + | userNick user == "*buffextras" , not debug = OmitMessage diff --git a/src/Client/Image.hs b/src/Client/Image.hs --- a/src/Client/Image.hs +++ b/src/Client/Image.hs @@ -19,6 +19,7 @@ import Client.Image.Palette import Client.Image.StatusLine import Client.Image.UserList +import Client.Image.Windows import Client.Message import Client.State import qualified Client.State.EditBox as Edit @@ -68,8 +69,8 @@ | otherwise -> userListImages network channel st (ChannelFocus network channel, FocusMasks mode) -> maskListImages mode network channel st + (_, FocusWindows) -> windowsImages st - -- subfocuses only make sense for channels _ -> chatMessageImages st chatMessageImages :: ClientState -> [Image] @@ -205,7 +206,7 @@ lineImage = beginning <|> content <|> ending - leftOfCurWidth = safeWcswidth txt + leftOfCurWidth = myWcswidth txt croppedImage | leftOfCurWidth < width = lineImage @@ -244,5 +245,16 @@ | z > w = acc + w -- didn't fit, will be filled in | otherwise = go (acc+1) (w-z) xs where - z | isControl x = 1 - | otherwise = safeWcwidth x + z = myWcwidth x + +-- | Version of 'safeWcwidth' that accounts for how control characters are +-- rendered +myWcwidth :: Char -> Int +myWcwidth x + | isControl x = 1 + | otherwise = safeWcwidth x + +-- | Version of 'safeWcswidth' that accounts for how control characters are +-- rendered +myWcswidth :: String -> Int +myWcswidth = sum . map myWcwidth diff --git a/src/Client/Image/ChannelInfo.hs b/src/Client/Image/ChannelInfo.hs --- a/src/Client/Image/ChannelInfo.hs +++ b/src/Client/Image/ChannelInfo.hs @@ -24,6 +24,7 @@ import Client.State.Channel import Client.State.Network import Control.Lens +import Data.HashSet (HashSet) import Data.Text (Text) import Data.Time import Graphics.Vty.Image @@ -38,14 +39,14 @@ | Just cs <- preview (clientConnection network) st , Just channel <- preview (csChannels . ix channelId) cs - = channelInfoImages' pal channel cs + = channelInfoImages' pal (clientHighlights cs st) channel | otherwise = [text' (view palError pal) "No channel information"] where pal = view (clientConfig . configPalette) st -channelInfoImages' :: Palette -> ChannelState -> NetworkState -> [Image] -channelInfoImages' pal !channel !cs +channelInfoImages' :: Palette -> HashSet Identifier -> ChannelState -> [Image] +channelInfoImages' pal myNicks !channel = topicLine : provenanceLines ++ creationLines @@ -56,7 +57,6 @@ topicLine = label "Topic: " <|> parseIrcText (view chanTopic channel) - myNick = view csNick cs utcTimeImage = string defAttr . formatTime defaultTimeLocale "%F %T" @@ -65,7 +65,7 @@ Nothing -> [] Just !prov -> [ label "Topic set by: " <|> - coloredUserInfo pal DetailedRender [myNick] (view topicAuthor prov) + coloredUserInfo pal DetailedRender myNicks (view topicAuthor prov) , label "Topic set on: " <|> utcTimeImage (view topicTime prov) ] diff --git a/src/Client/Image/Message.hs b/src/Client/Image/Message.hs --- a/src/Client/Image/Message.hs +++ b/src/Client/Image/Message.hs @@ -28,6 +28,7 @@ import Control.Lens import Data.Char import Data.Hashable (hash) +import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.List import Data.Maybe @@ -46,8 +47,8 @@ data MessageRendererParams = MessageRendererParams { rendStatusMsg :: [Char] -- ^ restricted message sigils , rendUserSigils :: [Char] -- ^ sender sigils - , rendNicks :: [Identifier] -- ^ nicknames to highlight - , rendMyNicks :: [Identifier] -- ^ nicknames to highlight in red + , rendNicks :: HashSet Identifier -- ^ nicknames to highlight + , rendMyNicks :: HashSet Identifier -- ^ nicknames to highlight in red , rendPalette :: Palette -- ^ nick color palette , rendNickPadding :: Maybe Integer -- ^ nick padding } @@ -55,11 +56,11 @@ -- | Default 'MessageRenderParams' with no sigils or nicknames specified defaultRenderParams :: MessageRendererParams defaultRenderParams = MessageRendererParams - { rendStatusMsg = "" - , rendUserSigils = "" - , rendNicks = [] - , rendMyNicks = [] - , rendPalette = defaultPalette + { rendStatusMsg = "" + , rendUserSigils = "" + , rendNicks = HashSet.empty + , rendMyNicks = HashSet.empty + , rendPalette = defaultPalette , rendNickPadding = Nothing } @@ -349,16 +350,16 @@ -- | Render a nickname in its hash-based color. coloredIdentifier :: - Palette -> - IdentifierColorMode -> - [Identifier] {- ^ my nicknames -} -> - Identifier -> + Palette {- ^ color palette -} -> + IdentifierColorMode {- ^ draw mode -} -> + HashSet Identifier {- ^ my nicknames -} -> + Identifier {- ^ identifier to draw -} -> Image coloredIdentifier palette icm myNicks ident = text' color (idText ident) where color - | ident `elem` myNicks = + | ident `HashSet.member` myNicks = case icm of PrivmsgIdentifier -> fromMaybe (view palSelf palette) @@ -374,10 +375,11 @@ -- If detailed mode the full user info including the username and hostname parts -- will be rendered. The nickname will be colored. coloredUserInfo :: - Palette -> - RenderMode -> - [Identifier] {- ^ my nicks -} -> - UserInfo -> Image + Palette {- ^ color palette -} -> + RenderMode {- ^ mode -} -> + HashSet Identifier {- ^ my nicks -} -> + UserInfo {- ^ userinfo to draw-} -> + Image coloredUserInfo palette NormalRender myNicks ui = coloredIdentifier palette NormalIdentifier myNicks (userNick ui) coloredUserInfo palette DetailedRender myNicks !ui = @@ -403,8 +405,8 @@ -- highlighted. parseIrcTextWithNicks :: Palette -> - [Identifier] {- ^ my nicks -} -> - [Identifier] {- ^ other nicks -} -> + HashSet Identifier {- ^ my nicks -} -> + HashSet Identifier {- ^ other nicks -} -> Text -> Image parseIrcTextWithNicks palette myNicks nicks txt | Text.any isControl txt = parseIrcText txt @@ -414,16 +416,16 @@ -- an image where all of the occurrences of those nicknames are colored. highlightNicks :: Palette -> - [Identifier] {- ^ my nicks -} -> - [Identifier] {- ^ other nicks -} -> + HashSet Identifier {- ^ my nicks -} -> + HashSet Identifier {- ^ other nicks -} -> Text -> Image highlightNicks palette myNicks nicks txt = horizCat (highlight1 <$> txtParts) where - nickSet = HashSet.fromList nicks txtParts = nickSplit txt + allNicks = HashSet.union myNicks nicks highlight1 part - | HashSet.member partId nickSet = coloredIdentifier palette PrivmsgIdentifier myNicks partId - | otherwise = text' defAttr part + | HashSet.member partId allNicks = coloredIdentifier palette PrivmsgIdentifier myNicks partId + | otherwise = text' defAttr part where partId = mkId part diff --git a/src/Client/Image/StatusLine.hs b/src/Client/Image/StatusLine.hs --- a/src/Client/Image/StatusLine.hs +++ b/src/Client/Image/StatusLine.hs @@ -147,6 +147,7 @@ subfocusName = case view clientSubfocus st of FocusMessages -> Nothing + FocusWindows -> Just $ string (view palLabel pal) "windows" FocusInfo -> Just $ string (view palLabel pal) "info" FocusUsers -> Just $ string (view palLabel pal) "users" FocusMasks m -> Just $ horizCat diff --git a/src/Client/Image/UserList.hs b/src/Client/Image/UserList.hs --- a/src/Client/Image/UserList.hs +++ b/src/Client/Image/UserList.hs @@ -49,7 +49,7 @@ matcher = clientMatcher st - myNicks = toListOf csNick cs + myNicks = clientHighlights cs st renderUser (ident, sigils) = string (view palSigil pal) sigils <|> @@ -95,7 +95,7 @@ where matcher = clientMatcher st - myNicks = toListOf csNick cs + myNicks = clientHighlights cs st pal = view (clientConfig . configPalette) st diff --git a/src/Client/Image/Windows.hs b/src/Client/Image/Windows.hs new file mode 100644 --- /dev/null +++ b/src/Client/Image/Windows.hs @@ -0,0 +1,72 @@ +{-| +Module : Client.Image.Windows +Description : View of the list of open windows +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module implements the rendering of the client window list. + +-} +module Client.Image.Windows (windowsImages) where + +import Client.Configuration +import Client.Image.Palette +import Client.State +import Client.State.Focus +import Client.State.Window +import Control.Lens +import Data.List +import qualified Data.Map as Map +import qualified Data.Text as Text +import Graphics.Vty.Image +import Irc.Identifier + +windowsImages :: ClientState -> [Image] +windowsImages st + = reverse + $ createColumns + $ zipWith (renderWindowColumns pal) names windows + where + cfg = view clientConfig st + windows = views clientWindows Map.toList st + + pal = view configPalette cfg + names = views configWindowNames Text.unpack cfg ++ repeat '?' + +renderWindowColumns :: Palette -> Char -> (Focus, Window) -> [Image] +renderWindowColumns pal name (focus, win) = + [ char (view palWindowName pal) name + , renderedFocus pal focus + , renderedWindowInfo pal win + ] + +createColumns :: [[Image]] -> [Image] +createColumns xs = map makeRow xs + where + columnWidths = maximum . map imageWidth <$> transpose xs + makeRow = horizCat + . intersperse (char defAttr ' ') + . zipWith resizeWidth columnWidths + +renderedFocus :: Palette -> Focus -> Image +renderedFocus pal focus = + case focus of + Unfocused -> + char (view palError pal) '*' + NetworkFocus network -> + text' (view palLabel pal) network + ChannelFocus network channel -> + text' (view palLabel pal) network <|> + char defAttr ':' <|> + text' (view palLabel pal) (idText channel) + +renderedWindowInfo :: Palette -> Window -> Image +renderedWindowInfo pal win = + string (view newMsgAttrLens pal) (views winUnread show win) <|> + char defAttr '/' <|> + string (view palActivity pal) (views winTotal show win) + where + newMsgAttrLens + | view winMention win = palMention + | otherwise = palActivity diff --git a/src/Client/Network/Async.hs b/src/Client/Network/Async.hs --- a/src/Client/Network/Async.hs +++ b/src/Client/Network/Async.hs @@ -27,8 +27,11 @@ , NetworkId , NetworkEvent(..) , createConnection - , abortConnection , send + + -- * Abort connections + , abortConnection + , TerminationReason(..) ) where import Client.Configuration.ServerSettings @@ -70,6 +73,16 @@ showsPrec p _ = showParen (p > 10) $ showString "NetworkConnection _" +-- | Exceptions used to kill connections manually. +data TerminationReason + = PingTimeout -- ^ sent when ping timer expires + | ForcedDisconnect -- ^ sent when client commands force disconnect + deriving Show + +instance Exception TerminationReason where + displayException PingTimeout = "connection killed due to ping timeout" + displayException ForcedDisconnect = "connection killed by client command" + -- | Schedule a message to be transmitted on the network connection. -- These messages are sent unmodified. The message should contain a -- newline terminator. @@ -77,8 +90,8 @@ send c msg = atomically (writeTQueue (connOutQueue c) msg) -- | Force the given connection to terminate. -abortConnection :: NetworkConnection -> IO () -abortConnection = cancel . connAsync +abortConnection :: TerminationReason -> NetworkConnection -> IO () +abortConnection reason c = cancelWith (connAsync c) reason -- | Initiate a new network connection according to the given 'ServerSettings'. -- All events on this connection will be added to the given queue. The resulting diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -33,9 +33,10 @@ , clientConnection , clientBell , clientExtensions - , initialClientState + , withClientState , clientShutdown , clientStartExtensions + , clientPark -- * Client operations , clientMatcher @@ -49,6 +50,7 @@ , removeNetwork , clientTick , applyMessageToClientState + , clientHighlights -- * Add messages to buffers , recordChannelMessage @@ -58,6 +60,7 @@ -- * Focus manipulation , changeFocus , changeSubfocus + , returnFocus , advanceFocus , retreatFocus , jumpToActivity @@ -67,6 +70,10 @@ , pageUp , pageDown + -- * Extensions + , ExtensionState + , esActive + ) where import Client.CApi @@ -80,11 +87,13 @@ import Client.State.Focus import Client.State.Network import Client.State.Window +import Control.Concurrent.MVar import Control.Concurrent.STM import Control.DeepSeq import Control.Exception import Control.Lens import Control.Monad +import Data.Default.Class import Data.Foldable import Data.Either import Data.HashMap.Strict (HashMap) @@ -98,6 +107,8 @@ import Data.Text (Text) import qualified Data.Text as Text import Data.Time +import Foreign.Ptr +import Foreign.StablePtr import Graphics.Vty import Irc.Codes import Irc.Identifier @@ -113,6 +124,7 @@ -- | All state information for the IRC client data ClientState = ClientState { _clientWindows :: !(Map Focus Window) -- ^ client message buffers + , _clientPrevFocus :: !Focus -- ^ previously focused buffer , _clientFocus :: !Focus -- ^ currently focused buffer , _clientSubfocus :: !Subfocus -- ^ sec @@ -133,11 +145,27 @@ , _clientIgnores :: !(HashSet Identifier) -- ^ ignored nicknames - , _clientExtensions :: [ActiveExtension] -- ^ Active extensions + , _clientExtensions :: !ExtensionState } +data ExtensionState = ExtensionState + { _esActive :: [ActiveExtension] + , _esMVar :: MVar ClientState + , _esStablePtr :: StablePtr (MVar ClientState) + } + makeLenses ''ClientState +makeLenses ''ExtensionState +clientPark :: ClientState -> (Ptr () -> IO a) -> IO (ClientState, a) +clientPark st k = + do let mvar = view (clientExtensions . esMVar) st + putMVar mvar st + let token = views (clientExtensions . esStablePtr) castStablePtrToPtr st + res <- k token + st' <- takeMVar mvar + return (st', res) + -- | 'Traversal' for finding the 'NetworkState' associated with a given network -- if that connection is currently active. clientConnection :: @@ -158,12 +186,16 @@ clientLine = views (clientTextBox . Edit.line) (\(Edit.Line n t) -> (n, t)) -- | Construct an initial 'ClientState' using default values. -initialClientState :: Configuration -> Vty -> IO ClientState -initialClientState cfg vty = +withClientState :: Configuration -> (ClientState -> IO a) -> IO a +withClientState cfg k = + + withVty $ \vty -> + withExtensionState $ \exts -> + do (width,height) <- displayBounds (outputIface vty) cxt <- initConnectionContext events <- atomically newTQueue - return ClientState + k ClientState { _clientWindows = _Empty # () , _clientNetworkMap = _Empty # () , _clientIgnores = _Empty # () @@ -173,6 +205,7 @@ , _clientHeight = height , _clientVty = vty , _clientEvents = events + , _clientPrevFocus = Unfocused , _clientFocus = Unfocused , _clientSubfocus = FocusMessages , _clientConnectionContext = cxt @@ -181,9 +214,24 @@ , _clientDetailView = False , _clientNextConnectionId = 0 , _clientBell = False - , _clientExtensions = [] + , _clientExtensions = exts } +-- | Initialize a 'Vty' value and run a continuation. Shutdown the 'Vty' +-- once the continuation finishes. +withVty :: (Vty -> IO a) -> IO a +withVty = bracket (mkVty def{bracketedPasteMode = Just True}) shutdown + +withExtensionState :: (ExtensionState -> IO a) -> IO a +withExtensionState k = + do mvar <- newEmptyMVar + bracket (newStablePtr mvar) freeStablePtr $ \stab -> + k ExtensionState + { _esActive = [] + , _esMVar = mvar + , _esStablePtr = stab + } + -- | Forcefully terminate the connection currently associated -- with a given network name. abortNetwork :: @@ -192,7 +240,7 @@ abortNetwork network st = case preview (clientConnection network) st of Nothing -> return st - Just cs -> do abortConnection (view csSocket cs) + Just cs -> do abortConnection ForcedDisconnect (view csSocket cs) return $ set (clientNetworkMap . at network) Nothing st -- | Add a message to the window associated with a given channel @@ -210,8 +258,8 @@ rendParams = MessageRendererParams { rendStatusMsg = statusModes , rendUserSigils = computeMsgLineSigils network channel' msg st - , rendNicks = channelUserList network channel' st - , rendMyNicks = toListOf (clientConnection network . csNick) st + , rendNicks = HashSet.fromList (channelUserList network channel' st) + , rendMyNicks = highlights , rendPalette = view (clientConfig . configPalette) st , rendNickPadding = view (clientConfig . configNickPadding) st } @@ -220,6 +268,7 @@ possibleStatusModes = view (clientConnection network . csStatusMsg) st (statusModes, channel') = splitStatusMsgModes possibleStatusModes channel importance = msgImportance msg st + highlights = clientHighlightsNetwork network st -- | Extract the status mode sigils from a message target. @@ -238,10 +287,12 @@ msgImportance msg st = let network = view msgNetwork msg me = preview (clientConnection network . csNick) st + highlights = clientHighlightsNetwork network st isMe x = Just x == me - checkTxt txt = case me of - Just me' | me' `elem` (mkId <$> nickSplit txt) -> WLImportant - _ -> WLNormal + checkTxt txt + | any (\x -> HashSet.member (mkId x) highlights) + (nickSplit txt) = WLImportant + | otherwise = WLNormal in case view msgBody msg of NormalBody{} -> WLImportant @@ -380,6 +431,7 @@ toWindowLine defaultRenderParams { rendPalette = view configPalette config , rendNickPadding = view configNickPadding config + , rendMyNicks = view configExtraHighlights config } @@ -392,7 +444,8 @@ markSeen :: ClientState -> ClientState markSeen st = case view clientSubfocus st of - FocusMessages -> overStrict (clientWindows . ix (view clientFocus st)) windowSeen st + FocusMessages -> + overStrict (clientWindows . ix (view clientFocus st)) windowSeen st _ -> st -- | Add the textbox input to the edit history and clear the textbox. @@ -444,13 +497,13 @@ case (clientConnections . at networkId <<.~ Nothing) st of (Nothing, _ ) -> error "removeNetwork: network not found" (Just cs, st1) -> - -- Only remove the network mapping if it hasn't already been replace + -- Only remove the network mapping if it hasn't already been replaced -- with a new one. This can happen during reconnect in particular. let network = view csNetwork cs in - case view (clientNetworkMap . at network) st of - Just i | i == networkId -> - (cs, set (clientNetworkMap . at network) Nothing st1) - _ -> (cs,st1) + forOf (clientNetworkMap . at network) st1 $ \mb -> + case mb of + Just i | i == networkId -> (cs,Nothing) + _ -> (cs,mb) addConnection :: Text -> ClientState -> IO ClientState addConnection network st = @@ -525,8 +578,8 @@ clientStopExtensions :: ClientState -> IO ClientState clientStopExtensions st = - do let (aes,st1) = (clientExtensions <<.~ []) st - (st2,_) <- withStableMVar st1 $ \ptr -> + do let (aes,st1) = (clientExtensions . esActive <<.~ []) st + (st2,_) <- clientPark st1 $ \ptr -> traverse_ (deactivateExtension ptr) aes return st2 @@ -535,13 +588,13 @@ clientStartExtensions st = do let cfg = view clientConfig st st1 <- clientStopExtensions st - (st2, res) <- withStableMVar st1 $ \ptr -> + (st2, res) <- clientPark st1 $ \ptr -> traverse (try . activateExtension ptr <=< resolveConfigurationPath) (view configExtensions cfg) let (errors, exts) = partitionEithers res st3 <- recordErrors errors st2 - return $! set clientExtensions exts st3 + return $! set (clientExtensions . esActive) exts st3 where recordErrors [] ste = return ste recordErrors es ste = @@ -601,16 +654,27 @@ (focus,_) = Map.elemAt i windows changeFocus :: Focus -> ClientState -> ClientState -changeFocus focus +changeFocus focus st = set clientScroll 0 + . updatePrevious . set clientFocus focus . set clientSubfocus FocusMessages + $ st + where + oldFocus = view clientFocus st + updatePrevious + | focus == oldFocus = id + | otherwise = set clientPrevFocus oldFocus changeSubfocus :: Subfocus -> ClientState -> ClientState changeSubfocus focus = set clientScroll 0 . set clientSubfocus focus +-- | Return to previously focused window. +returnFocus :: ClientState -> ClientState +returnFocus st = changeFocus (view clientPrevFocus st) st + -- | Step focus to the next window when on message view. Otherwise -- switch to message view. advanceFocus :: ClientState -> ClientState @@ -637,3 +701,15 @@ where isForward = not isReversed (l,r) = Map.split (view clientFocus st) (view clientWindows st) + +clientHighlights :: NetworkState -> ClientState -> HashSet Identifier +clientHighlights cs st = + HashSet.insert + (view csNick cs) + (view (clientConfig . configExtraHighlights) st) + +clientHighlightsNetwork :: Text -> ClientState -> HashSet Identifier +clientHighlightsNetwork network st = + case preview (clientConnection network) st of + Just cs -> clientHighlights cs st + Nothing -> view (clientConfig . configExtraHighlights) st diff --git a/src/Client/State/EditBox.hs b/src/Client/State/EditBox.hs --- a/src/Client/State/EditBox.hs +++ b/src/Client/State/EditBox.hs @@ -42,12 +42,13 @@ , killEnd , killWordBackward , killWordForward - , paste + , yank , left , right , leftWord , rightWord , insert + , insertPaste , insertString , earlier , later @@ -165,7 +166,7 @@ = case view (content . below) e of [] -> e b:bs -> set (content . below) bs - $ updateYankBuffer KillForward b e -- add newline? + $ updateYankBuffer KillForward ('\n':b) e | otherwise = set line (endLine keep) $ updateYankBuffer KillForward kill e @@ -178,10 +179,10 @@ killHome :: EditBox -> EditBox killHome e | null kill - = case view (content.above) e of + = case view (content . above) e of [] -> e - a:as -> set (content.above) as - $ updateYankBuffer KillBackward a e + a:as -> set (content . above) as + $ updateYankBuffer KillBackward (a++"\n") e | otherwise = set line (Line 0 keep) @@ -191,15 +192,15 @@ (kill,keep) = splitAt n txt -- | Insert the yank buffer at the cursor. -paste :: EditBox -> EditBox -paste e +yank :: EditBox -> EditBox +yank e = over content (insertString (view yankBuffer e)) $ set lastOperation OtherOperation e -- | Kill the content from the cursor back to the previous word boundary. -- When @yank@ is set the yank buffer will be updated. killWordBackward :: Bool {- ^ yank -} -> EditBox -> EditBox -killWordBackward yank e +killWordBackward saveKill e = sometimesUpdateYank $ set line (Line (length l') (l'++r)) $ e @@ -212,13 +213,13 @@ yanked = reverse (sp++wd) sometimesUpdateYank - | yank = updateYankBuffer KillBackward yanked + | saveKill = updateYankBuffer KillBackward yanked | otherwise = id -- don't update operation -- | Kill the content from the curser forward to the next word boundary. -- When @yank@ is set the yank buffer will be updated killWordForward :: Bool {- ^ yank -} -> EditBox -> EditBox -killWordForward yank e +killWordForward saveKill e = sometimesUpdateYank $ set line (Line (length l) (l++r2)) $ e @@ -230,11 +231,16 @@ yanked = sp++wd sometimesUpdateYank - | yank = updateYankBuffer KillForward yanked + | saveKill = updateYankBuffer KillForward yanked | otherwise = id -- don't update operation -- | Insert a character at the cursor and advance the cursor. insert :: Char -> EditBox -> EditBox insert c = set lastOperation OtherOperation - . over content (insertString [c]) + . over content (insertChar c) + +insertPaste :: String -> EditBox -> EditBox +insertPaste paste + = over content (insertPastedString paste) + . set lastOperation OtherOperation diff --git a/src/Client/State/EditBox/Content.hs b/src/Client/State/EditBox/Content.hs --- a/src/Client/State/EditBox/Content.hs +++ b/src/Client/State/EditBox/Content.hs @@ -6,11 +6,47 @@ License : ISC Maintainer : emertens@gmail.com +This module manages simple text navigation and manipulation, +but leaves more complicated operations like yank/kill and +history management to "Client.State.EditBox" + -} -module Client.State.EditBox.Content where +module Client.State.EditBox.Content + ( + -- * Multiple lines + Content + , above + , below + , singleLine + , noContent + , shift + -- * Focused line + , Line(..) + , HasLine(..) + , endLine + + -- * Movements + , left + , right + + , leftWord + , rightWord + + , jumpLeft + , jumpRight + + -- * Edits + , delete + , backspace + , insertPastedString + , insertString + , insertChar + ) where + import Control.Lens hiding (below) -import Data.Char +import Data.Char (isAlphaNum) +import Data.List (find) data Line = Line { _pos :: !Int @@ -58,6 +94,8 @@ shift (Content a@(_:_) l b) = (last a, Content (init a) l b) shift (Content [] l (b:bs)) = (view text l, Content [] (beginLine b) bs) +-- | When at beginning of line, jump to beginning of previous line. +-- Otherwise jump to beginning of current line. jumpLeft :: Content -> Content jumpLeft c | view pos c == 0 = maybe c begin1 (backwardLine c) @@ -65,17 +103,18 @@ where begin1 = set pos 0 +-- | When at end of line, jump to end of next line. +-- Otherwise jump to end of current line. jumpRight :: Content -> Content jumpRight c | view pos c == len = maybe c end1 (forwardLine c) | otherwise = set pos len c - where len = views text length c end1 l = set pos (views text length l) l --- Move the cursor left, across lines if necessary. +-- | Move the cursor left, across lines if necessary. left :: Content -> Content left c = case compare (view pos c) 0 of @@ -83,7 +122,7 @@ EQ | Just c' <- backwardLine c -> c' _ -> c --- Move the cursor right, across lines if necessary. +-- | Move the cursor right, across lines if necessary. right :: Content -> Content right c = let Line n s = view line c in @@ -95,38 +134,30 @@ -- | Move the cursor left to the previous word boundary. leftWord :: Content -> Content leftWord c - | n == 0 - = maybe c leftWord (backwardLine c) - | otherwise - = case search of - [] -> set pos 0 c - (i,_):_ -> set pos (i+1) c + | n == 0 = maybe c leftWord (backwardLine c) + | otherwise = set pos search c where - Line n txt = view line c - search = dropWhile (isAlphaNum . snd) - $ dropWhile (not . isAlphaNum . snd) - $ reverse - $ take n - $ zip [0..] - $ txt + Line n txt = view line c + search = maybe 0 fst + $ find (not . isAlphaNum . snd) + $ dropWhile (not . isAlphaNum . snd) + $ reverse + $ take n + $ zip [1..] txt -- | Move the cursor right to the next word boundary. rightWord :: Content -> Content rightWord c - | n == length txt - = case forwardLine c of - Nothing -> c - Just c' -> rightWord c' - | otherwise - = case search of - [] -> set pos (length txt) c - (i,_):_ -> set pos i c + | n == txtLen = maybe c rightWord (forwardLine c) + | otherwise = set pos search c where - Line n txt = view line c - search = dropWhile (isAlphaNum . snd) - $ dropWhile (not . isAlphaNum . snd) - $ drop n - $ zip [0..] txt + Line n txt = view line c + txtLen = length txt + search = maybe txtLen fst + $ find (not . isAlphaNum . snd) + $ dropWhile (not . isAlphaNum . snd) + $ drop n + $ zip [0..] txt -- | Delete the character before the cursor. backspace :: Content -> Content @@ -155,6 +186,39 @@ . set text (s ++ b) $ c +-- | Insert character at cursor, cursor is advanced. +insertChar :: Char -> Content -> Content +insertChar '\n' c + = over above (view text c :) + $ set line emptyLine c + +insertChar ins c = over line aux c + where + aux (Line n txt) = + case splitAt n txt of + (preS, postS) -> Line (n+1) (preS ++ ins : postS) + +-- | Smarter version of 'insertString' that removes spurious newlines. +insertPastedString :: String -> Content -> Content +insertPastedString paste c = insertString (foldr scrub "" paste) c + where + cursorAtEnd = null (view below c) + && length (view text c) == view pos c + + -- ignore formfeeds + scrub '\r' xs = xs + + -- avoid adding empty lines + scrub '\n' xs@('\n':_) = xs + + -- avoid adding trailing newline at end of textbox + scrub '\n' "" | cursorAtEnd = "" + + -- pass-through everything else + scrub x xs = x : xs + +-- | Insert string at cursor, cursor is advanced to the +-- end of the inserted string. insertString :: String -> Content -> Content insertString ins c = case push (view above c) (preS ++ l) ls of @@ -168,6 +232,7 @@ push stk x [] = (stk, Line (length x) (x ++ postS)) push stk x (y:ys) = push (x:stk) y ys +-- | Advance to the beginning of the next line forwardLine :: Content -> Maybe Content forwardLine c = case view below c of @@ -177,6 +242,7 @@ $ set below bs $ set line (beginLine b) c +-- | Retreat to the end of the previous line backwardLine :: Content -> Maybe Content backwardLine c = case view above c of diff --git a/src/Client/State/Focus.hs b/src/Client/State/Focus.hs --- a/src/Client/State/Focus.hs +++ b/src/Client/State/Focus.hs @@ -30,6 +30,7 @@ , _FocusInfo , _FocusUsers , _FocusMasks + , _FocusWindows ) where import Control.Lens @@ -46,12 +47,13 @@ makePrisms ''Focus --- | Subfocus for a channel view +-- | Subfocus view data Subfocus - = FocusMessages -- ^ Show chat messages + = FocusMessages -- ^ Show messages | FocusInfo -- ^ Show channel metadata - | FocusUsers -- ^ Show user list - | FocusMasks !Char -- ^ Show mask list for given mode + | FocusUsers -- ^ Show channel user list + | FocusMasks !Char -- ^ Show channel mask list for given mode + | FocusWindows -- ^ Show client windows deriving (Eq,Show) makePrisms ''Subfocus diff --git a/src/Client/State/Network.hs b/src/Client/State/Network.hs --- a/src/Client/State/Network.hs +++ b/src/Client/State/Network.hs @@ -407,7 +407,7 @@ . doMode msgWhen who chanId modes params . set (csChannels . ix chanId . chanModes) Map.empty where chanId = mkId chan - !who = UserInfo (mkId "*") "" "" + !who = UserInfo "*" "" "" _ -> id _ -> id @@ -600,8 +600,8 @@ initialMessages cs = [ ircCapLs ] ++ [ ircPass pass | Just pass <- [view ssPassword ss]] - ++ [ ircUser (view ssUser ss) False True (view ssReal ss) - , ircNick (view csNick cs) + ++ [ ircNick (view csNick cs) + , ircUser (view ssUser ss) False True (view ssReal ss) ] where ss = view csSettings cs @@ -779,7 +779,7 @@ applyTimedAction action cs = case action of TimedDisconnect -> - do abortConnection (view csSocket cs) + do abortConnection PingTimeout (view csSocket cs) return $! set csNextPingTime Nothing cs TimedSendPing -> diff --git a/src/Client/State/Window.hs b/src/Client/State/Window.hs --- a/src/Client/State/Window.hs +++ b/src/Client/State/Window.hs @@ -17,6 +17,7 @@ Window(..) , winMessages , winUnread + , winTotal , winMention -- * Window lines @@ -53,6 +54,7 @@ data Window = Window { _winMessages :: ![WindowLine] -- ^ Messages to display, newest first , _winUnread :: !Int -- ^ Messages added since buffer was visible + , _winTotal :: !Int -- ^ Messages in buffer , _winMention :: !Bool -- ^ Indicates an important event is unread } @@ -71,6 +73,7 @@ emptyWindow = Window { _winMessages = [] , _winUnread = 0 + , _winTotal = 0 , _winMention = False } @@ -79,6 +82,7 @@ addToWindow :: WindowLineImportance -> WindowLine -> Window -> Window addToWindow importance !msg !win = Window { _winMessages = msg : _winMessages win + , _winTotal = _winTotal win + 1 , _winUnread = _winUnread win + (if importance == WLBoring then 0 else 1) , _winMention = _winMention win diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -11,12 +11,9 @@ module Main where import Control.Concurrent -import Control.Exception import Control.Lens import Control.Monad -import Data.Default.Class import Data.Text (Text) -import Graphics.Vty import System.Exit import System.IO @@ -27,22 +24,16 @@ import Client.State import Client.State.Focus --- | Initialize a 'Vty' value and run a continuation. Shutdown the 'Vty' --- once the continuation finishes. -withVty :: (Vty -> IO a) -> IO a -withVty = bracket (mkVty def{bracketedPasteMode = Just True}) shutdown - -- | Main action for IRC client main :: IO () main = do args <- getCommandArguments cfg <- loadConfiguration' (view cmdArgConfigFile args) - withVty $ \vty -> - runInUnboundThread $ - initialClientState cfg vty >>= - clientStartExtensions >>= - addInitialNetworks (view cmdArgInitialNetworks args) >>= - eventLoop + runInUnboundThread $ + withClientState cfg $ + clientStartExtensions >=> + addInitialNetworks (view cmdArgInitialNetworks args) >=> + eventLoop -- | Load configuration and handle errors along the way. loadConfiguration' :: Maybe FilePath -> IO Configuration