diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,21 @@ # Revision history for glirc +## 2.38 + +* Avoid ping timeout disconnects while other packets are still arriving +* Add `never-highlights` configuration setting to stop common words from being treated as nicknames +* Add a multi-line editor mode (default toggle with F6) +* More tolerate nickname completion +* Preserve server names in server replies (visible in detail view) +* Window names are persistent rather than alphabetical. Manage them with `/setname` and `/setwindow` +* Added hook for extension to query window lines +* More complete rendering for rare server replies +* Prettier columns in `/names` +* Add small scroll with Meta-PgUp/PgDown +* Built-in support for `/umode` for changing user modes (a common macro previously) +* Support strikethrough formatting (can require terminfo edits on common terminals to see it) +* Removed DCC support + ## 2.37 * Add `/new-self-signed-certificate PATH [keysize]` to make it easier to configure secure services logon diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -95,8 +95,9 @@ username: "yourusername" realname: "Your real name" password: "IRC server password" - tls: yes -- or: yes-insecure or no + tls: yes -- or: no, or: starttls -- enabling tls automatically uses port 6697 + tls-verify: yes -- or: no tls-client-cert: "/path/to/cert.pem" tls-client-key: "/path/to/cert.key" @@ -104,8 +105,9 @@ servers: * name: "fn" hostname: "chat.freenode.net" - sasl-username: "someuser" - sasl-password: "somepass" + sasl: + username: "someuser" + password: "somepass" socks-host: "socks5.example.com" socks-port: 8080 -- defaults to 1080 log-dir: "/home/myuser/ircLogs" @@ -198,10 +200,9 @@ | `username` | text | server username | | `realname` | text | real name / GECOS | | `password` | text | server password | -| `sasl-username` | text | SASL username | -| `sasl-password` | text | SASL password (PLAIN mode) | -| `sasl-ecdsa-key` | text | Path ecdsa private key file (ECDSA-NIST256P-CHALLENGE mode) | -| `tls` | yes/yes-insecure/no | use TLS to connect (insecure mode disables certificate checks) | +| `sasl` | sasl-settings | SASL authentication settings | +| `tls` | yes/no/starttls | use TLS to connect | +| `tls-verify` | yes/no | enable/ disable TLS certificate checks | | `tls-client-cert` | text | path to TLS client certificate | | `tls-client-key` | text | path to TLS client key | | `tls-server-cert` | text | CA certificate to use when validating certificates | @@ -216,6 +217,19 @@ | `reconnect-attempts` | int | number of reconnections to attempt on error | | `autoconnect` | yes or no | automatically connect at client startup | | `nick-completion` | default or slack | set this to slack to use `@` sigils when completing nicks | + +SASL Settings +------------- + +By default SASL will use PLAIN mode, but you can specify one of: `plain`, `external`, or `ecdsa-nist256p-challenge`. + +| setting | type | description | +|-----------------------|----------------------|----------------------------------------------------------------| +| `mechanism` | optional mechanism | SASL mechanism (defaults to PLAIN) | +| `username` | text | SASL username (PLAIN and ECDSA-NIST256P-CHALLENGE mode) | +| `password` | text | SASL password (PLAIN mode) | +| `private-key` | text | Path to ECDSA private key file (ECDSA-NIST256P-CHALLENGE mode) | +| `authzid` | text | Authorization identity (very rarely needed) | Palette ------- diff --git a/exec/Exports.hs b/exec/Exports.hs --- a/exec/Exports.hs +++ b/exec/Exports.hs @@ -37,3 +37,5 @@ foreign export ccall glirc_resolve_path :: Glirc_resolve_path foreign export ccall glirc_set_timer :: Glirc_set_timer foreign export ccall glirc_cancel_timer :: Glirc_cancel_timer +foreign export ccall glirc_window_lines :: Glirc_window_lines +foreign export ccall glirc_thread :: Glirc_thread diff --git a/exec/linux_exported_symbols.txt b/exec/linux_exported_symbols.txt --- a/exec/linux_exported_symbols.txt +++ b/exec/linux_exported_symbols.txt @@ -22,4 +22,6 @@ glirc_free_strings; glirc_set_timer; glirc_cancel_timer; +glirc_window_lines; +glirc_thread; }; diff --git a/exec/macos_exported_symbols.txt b/exec/macos_exported_symbols.txt --- a/exec/macos_exported_symbols.txt +++ b/exec/macos_exported_symbols.txt @@ -21,3 +21,5 @@ _glirc_free_strings _glirc_set_timer _glirc_cancel_timer +_glirc_window_lines +_glirc_thread diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: glirc -version: 2.37 +version: 2.38 synopsis: Console IRC client description: Console IRC client . @@ -23,7 +23,7 @@ tested-with: GHC==8.6.5 custom-setup - setup-depends: base >=4.12 && <4.15, + setup-depends: base >=4.12 && <4.16, filepath >=1.4 && <1.5, Cabal >=2.2 && <4 @@ -69,7 +69,6 @@ Client.Commands.Chat Client.Commands.Certificate Client.Commands.Connection - Client.Commands.DCC Client.Commands.Exec Client.Commands.Interpolation Client.Commands.Operator @@ -112,7 +111,6 @@ Client.Options Client.State Client.State.Channel - Client.State.DCC Client.State.EditBox Client.State.EditBox.Content Client.State.Extensions @@ -124,7 +122,6 @@ Client.View.Cert Client.View.ChannelInfo Client.View.Digraphs - Client.View.DCCList Client.View.Help Client.View.IgnoreList Client.View.KeyMap @@ -150,7 +147,7 @@ autogen-modules: Paths_glirc Build_glirc - build-depends: base >=4.11 && <4.15, + build-depends: base >=4.11 && <4.16, HsOpenSSL >=0.11 && <0.12, async >=2.2 && <2.3, attoparsec >=0.13 && <0.14, @@ -164,26 +161,25 @@ free >=4.12 && <5.2, gitrev >=1.2 && <1.4, hashable >=1.2.4 && <1.4, - hookup >=0.5 && <0.6, - irc-core ^>=2.9, + hookup ^>=0.6, + irc-core ^>=2.10, kan-extensions >=5.0 && <5.3, - lens >=4.14 && <4.20, - random >=1.2 && <1.3, + lens >=4.14 && <5.1, + random >=1.1 && <1.3, network >=2.6.2 && <3.2, process >=1.4.2 && <1.7, psqueues >=0.2.7 && <0.3, regex-tdfa >=1.3.1 && <1.4, - semigroupoids >=5.1 && <5.4, split >=0.2 && <0.3, stm >=2.4 && <2.6, - template-haskell >=2.11 && <2.17, + template-haskell >=2.11 && <2.18, text >=1.2.2 && <1.3, - time >=1.6 && <1.11, + time >=1.6 && <1.12, transformers >=0.5.2 && <0.6, unix >=2.7 && <2.8, unordered-containers >=0.2.7 && <0.3, vector >=0.11 && <0.13, - vty >=5.23.1 && <5.31 + vty >=5.31 && <5.34 test-suite test type: exitcode-stdio-1.0 diff --git a/include/glirc-api.h b/include/glirc-api.h --- a/include/glirc-api.h +++ b/include/glirc-api.h @@ -89,6 +89,8 @@ char * glirc_resolve_path(struct glirc *G, const char *path, size_t path_len); timer_id glirc_set_timer(struct glirc *G, unsigned long millis, timer_callback *cb, void *dat); void *glirc_cancel_timer(struct glirc *G, timer_id tid); +char ** glirc_window_lines(struct glirc *G, const char *net, size_t netlen, const char *tgt, size_t tgtlen, int filtered); +void glirc_thread(struct glirc *G, void *(*start)(void *), void(*finish)(void*), void *arg); void glirc_free_string(char *); void glirc_free_strings(char **); diff --git a/src/Client/CApi.hs b/src/Client/CApi.hs --- a/src/Client/CApi.hs +++ b/src/Client/CApi.hs @@ -19,11 +19,14 @@ , extensionSymbol , openExtension , startExtension - , deactivateExtension + , stopExtension , notifyExtension , commandExtension , chatExtension + , ThreadEntry(..) + , threadFinish + , popTimer , pushTimer , cancelTimer @@ -78,10 +81,13 @@ , aeMajorVersion, aeMinorVersion :: !Int , aeTimers :: !(IntPSQ UTCTime TimerEntry) , aeNextTimer :: !Int + , aeThreads :: !Int + , aeLive :: !Bool } data TimerEntry = TimerEntry !(FunPtr TimerCallback) !(Ptr ()) +data ThreadEntry = ThreadEntry !(FunPtr ThreadFinish) !(Ptr ()) -- | Find the earliest timer ready to run if any are available. popTimer :: @@ -90,6 +96,7 @@ {- ^ earlier time, callback, callback state, updated extension -} popTimer ae = do let timers = aeTimers ae + guard (aeLive ae) (timerId, time, TimerEntry fun ptr, timers') <- IntPSQ.minView timers let ae' = ae { aeTimers = timers' } return (time, fromIntegral timerId, fun, ptr, ae') @@ -138,6 +145,8 @@ , aeMajorVersion = fromIntegral (fgnMajorVersion fgn) , aeMinorVersion = fromIntegral (fgnMinorVersion fgn) , aeNextTimer = 1 + , aeThreads = 0 + , aeLive = True } startExtension :: @@ -157,16 +166,13 @@ let len = fromIntegral (length args) liftIO (runStartExtension f stab extPath argsArray len) --- | Call the stop callback of the extension if it is defined --- and unload the shared object. -deactivateExtension :: ActiveExtension -> IO () -deactivateExtension ae = +stopExtension :: ActiveExtension -> IO () +stopExtension ae = do let f = fgnStop (aeFgn ae) unless (nullFunPtr == f) $ runStopExtension f (aeSession ae) dlclose (aeDL ae) - -- | Call all of the process chat callbacks in the list of extensions. -- This operation marshals the IRC message once and shares that across -- all of the callbacks. @@ -208,6 +214,10 @@ let f = fgnCommand (aeFgn ae) liftIO $ unless (f == nullFunPtr) $ runProcessCommand f (aeSession ae) cmd + +-- | Notify an extension that one of its threads has finished. +threadFinish :: ThreadEntry -> IO () +threadFinish (ThreadEntry f x) = runThreadFinish f x -- | 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 @@ -82,9 +82,14 @@ , Glirc_cancel_timer , glirc_cancel_timer + , Glirc_window_lines + , glirc_window_lines + + , Glirc_thread + , glirc_thread ) where -import Client.CApi (cancelTimer, pushTimer) +import Client.CApi (cancelTimer, pushTimer, ThreadEntry(..), ActiveExtension(aeThreads)) import Client.CApi.Types import Client.Configuration import Client.Message @@ -92,9 +97,11 @@ import Client.State.Channel import Client.State.Focus import Client.State.Network -import Client.State.Window +import Client.State.Window (windowClear, windowSeen, winMessages, wlText) import Client.UserHost +import Control.Concurrent (forkOS) import Control.Concurrent.MVar +import Control.Concurrent.STM (atomically, writeTQueue) import Control.Exception import Control.Lens import Control.Monad (unless) @@ -106,6 +113,7 @@ import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import qualified Data.Text as Text +import qualified Data.Text.Lazy as LText import qualified Data.Text.Foreign as Text import Data.Time import Foreign.C @@ -555,7 +563,7 @@ mvar <- derefToken stab modifyMVar_ mvar $ \(i,st) -> - let st' = set (clientWindows . ix focus) emptyWindow st + let st' = over (clientWindows . ix focus) windowClear st in st' `seq` return (i,st') ------------------------------------------------------------------------ @@ -764,3 +772,62 @@ in return $! case mb of Just (First (Just ptr), st') -> ((i,st'), ptr) _ -> ((i, st), nullPtr) + +------------------------------------------------------------------------ + +-- | Type of 'glirc_window_lines' extension entry-point +type Glirc_window_lines = + Ptr () {- ^ api token -} -> + CString {- ^ network name -} -> + CSize {- ^ network length -} -> + CString {- ^ target name -} -> + CSize {- ^ target length -} -> + CInt {- ^ use filter -} -> + IO (Ptr CString) {- ^ null terminated array of null terminated strings -} + +-- | This extension entry-point allocates a list of all the window lines for +-- the requested window. The lines are presented with newest line at the head +-- of the list. +-- The caller is responsible for freeing successful result with +-- @glirc_free_strings@. +glirc_window_lines :: Glirc_window_lines +glirc_window_lines stab net netL tgt tgtL filt = + do mvar <- derefToken stab + (_,st) <- readMVar mvar + network <- peekFgnStringLen (FgnStringLen net netL) + channel <- peekFgnStringLen (FgnStringLen tgt tgtL) + let focus + | Text.null network = Unfocused + | Text.null channel = NetworkFocus network + | otherwise = ChannelFocus network (mkId channel) + filterFun + | filt == 0 = id + | otherwise = clientFilter st id + strs = toListOf (clientWindows . ix focus . winMessages . each . wlText) st + ptrs <- traverse (newCString . LText.unpack) (filterFun strs) + newArray0 nullPtr ptrs + +------------------------------------------------------------------------ + +-- | Type of 'glirc_thread' extension entry-point +type Glirc_thread = + Ptr () {- ^ api token -} -> + FunPtr (Ptr () -> IO (Ptr ())) {- ^ start -} -> + FunPtr (Ptr () -> IO ()) {- ^ finish -} -> + Ptr () {- ^ start argument -} -> + IO () {- ^ null terminated array of null terminated strings -} + +-- | This extension entry-point allocates a list of all the window lines for +-- the requested window. The lines are presented with newest line at the head +-- of the list. +-- The caller is responsible for freeing successful result with +-- @glirc_free_strings@. +glirc_thread :: Glirc_thread +glirc_thread stab start finish arg = + do mvar <- derefToken stab + modifyMVar_ mvar $ \(i,st) -> + do _ <- forkOS $ + do result <- runThreadStart start arg + atomically (writeTQueue (view clientThreadJoins st) (i, ThreadEntry finish result)) + let incThreads ae = ae { aeThreads = aeThreads ae + 1} + pure (i, over (clientExtensions . esActive . ix i) incThreads 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 @@ -23,6 +23,7 @@ , ProcessChat , TimerCallback , TimerId + , ThreadFinish -- * Strings , FgnStringLen(..) @@ -44,6 +45,8 @@ , runProcessCommand , runProcessChat , runTimerCallback + , runThreadStart + , runThreadFinish -- * report message codes , MessageCode(..), normalMessage, errorMessage @@ -137,6 +140,16 @@ TimerId {- ^ timer ID -} -> IO () +-- | Startup function for threads +type ThreadStart = + Ptr () {- ^ initial argument -} -> + IO (Ptr ()) {- ^ result for ThreadFinish -} + +-- | @typedef void thread_finish(void *glirc, void *S)@ +type ThreadFinish = + Ptr () {- ^ thread result -} -> + IO () + -- | Type of dynamic function pointer wrappers. These convert C -- function-pointers into Haskell functions. type Dynamic a = FunPtr a -> a @@ -153,6 +166,10 @@ foreign import ccall "dynamic" runProcessChat :: Dynamic ProcessChat -- | Dynamic import for timer callback foreign import ccall "dynamic" runTimerCallback :: Dynamic TimerCallback +-- | Dynamic import for thread starts +foreign import ccall "dynamic" runThreadStart :: Dynamic ThreadStart +-- | Dynamic import for 'ThreadFinish'. +foreign import ccall "dynamic" runThreadFinish :: Dynamic ThreadFinish ------------------------------------------------------------------------ diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -56,7 +56,6 @@ import Client.Commands.Certificate (newCertificateCommand) import Client.Commands.Chat (chatCommands, chatCommand', executeChat) import Client.Commands.Connection (connectionCommands) -import Client.Commands.DCC (dccCommands) import Client.Commands.Operator (operatorCommands) import Client.Commands.Queries (queryCommands) import Client.Commands.Toggles (togglesCommands) @@ -332,8 +331,8 @@ ], togglesCommands, connectionCommands, windowCommands, chatCommands, - queryCommands, channelCommands, zncCommands, operatorCommands, - dccCommands ] + queryCommands, channelCommands, zncCommands, operatorCommands + ] -- | Implementation of @/exit@ command. cmdExit :: ClientCommand () @@ -406,12 +405,13 @@ commandNameCompletion :: Bool -> ClientState -> Maybe ClientState commandNameCompletion isReversed st = do guard (cursorPos == n) - clientTextBox (wordComplete plainWordCompleteMode isReversed [] possibilities) st + clientTextBox (wordComplete (' ' /=) plainWordCompleteMode isReversed [] possibilities) st where n = length white + length leadingPart (cursorPos, line) = clientLine st (white, leadingPart) = takeWhile (' ' /=) <$> span (' '==) line - possibilities = Text.cons '/' <$> commandNames + + possibilities = caseText . Text.cons '/' <$> commandNames commandNames = keys commands ++ keys (view (clientConfig . configMacros) st) @@ -517,9 +517,11 @@ Just url -> openUrl opener (Text.unpack url) st Nothing -> commandFailureMsg "bad url number" st -openUrl :: FilePath -> String -> ClientState -> IO CommandResult -openUrl opener url st = - do res <- try (callProcess opener [url]) +openUrl :: UrlOpener -> String -> ClientState -> IO CommandResult +openUrl (UrlOpener opener args) url st = + do let argStr (UrlArgLiteral str) = str + argStr UrlArgUrl = url + res <- try (callProcess opener (map argStr args)) case res of Left e -> commandFailureMsg (Text.pack (displayException (e :: IOError))) st Right{} -> commandSuccess st diff --git a/src/Client/Commands/Channel.hs b/src/Client/Commands/Channel.hs --- a/src/Client/Commands/Channel.hs +++ b/src/Client/Commands/Channel.hs @@ -305,7 +305,7 @@ ([Identifier],[Identifier]) {- ^ (hint, complete) -} computeModeCompletion pol mode channel cs st | mode `elem` view modesLists modeSettings = - if pol then ([],usermasks) else ([],masks) + if pol then ([],usermasks <> accounts) else ([],masks) | otherwise = (activeNicks st, nicks) where modeSettings = view csModeTypes cs @@ -317,6 +317,12 @@ [ mkId ("*!*@" <> host) | nick <- HashMap.keys (view (csChannels . ix channel . chanUsers) cs) , UserAndHost _ host _ <- toListOf (csUsers . ix nick) cs + ] + accounts = + [ mkId ("$a:" <> account) + | nick <- HashMap.keys (view (csChannels . ix channel . chanUsers) cs) + , UserAndHost _ _ account <- toListOf (csUsers . ix nick) cs + , not (Text.null account) ] -- | Predicate for mode commands that can be performed without ops diff --git a/src/Client/Commands/Chat.hs b/src/Client/Commands/Chat.hs --- a/src/Client/Commands/Chat.hs +++ b/src/Client/Commands/Chat.hs @@ -199,6 +199,25 @@ $ NetworkCommand cmdNotice simpleNetworkTab , Command + (pure "wallops") + (remainingArg "message") + "\^BParameters:\^B\n\ + \\n\ + \ message: Formatted message body\n\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ Send a network-wide WALLOPS message. These message go out\n\ + \ to users who have the 'w' usermode set.\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /wallops Hi everyone, thanks for using this network!\n\ + \\n\ + \\^BSee also:\^B me, msg, say\n" + $ NetworkCommand cmdWallops simpleNetworkTab + + , Command (pure "ctcp") (liftA3 (,,) (simpleToken "target") (simpleToken "command") (remainingArg "arguments")) "\^BParameters:\^B\n\ @@ -381,10 +400,22 @@ argTxt = Text.pack args tgtTxt = Text.pack target - sendMsg cs (ircPrivmsg tgtTxt ("\^A" <> cmdTxt <> " " <> argTxt <> "\^A")) + sendMsg cs (ircPrivmsg tgtTxt + ("\^A" <> cmdTxt <> + (if Text.null argTxt then "" else " " <> argTxt) <> + "\^A")) chatCommand (\src tgt -> Ctcp src tgt cmdTxt argTxt) tgtTxt cs st + +-- | Implementation of @/wallops@ +cmdWallops :: NetworkCommand String +cmdWallops cs st rest + | null rest = commandFailureMsg "empty message" st + | otherwise = + do let restTxt = Text.pack rest + sendMsg cs (ircWallops restTxt) + commandSuccess st -- | Implementation of @/notice@ cmdNotice :: NetworkCommand (String, String) diff --git a/src/Client/Commands/Connection.hs b/src/Client/Commands/Connection.hs --- a/src/Client/Commands/Connection.hs +++ b/src/Client/Commands/Connection.hs @@ -20,7 +20,7 @@ import Control.Lens import qualified Data.HashMap.Strict as HashMap import qualified Data.Text as Text -import Irc.Commands (ircQuit) +import Irc.Commands (ircMode, ircQuit) connectionCommands :: CommandSection connectionCommands = CommandSection "Connection commands" @@ -63,7 +63,18 @@ "Show the TLS certificate for the current connection.\n" $ NetworkCommand cmdCert noNetworkTab + , Command + (pure "umode") + (remainingArg "modes") + "Apply a user-mode change.\n" + $ NetworkCommand cmdUmode noNetworkTab ] + +cmdUmode :: NetworkCommand String +cmdUmode cs st rest = + do let args = Text.words (Text.pack rest) + sendMsg cs (ircMode (view csNick cs) args) + commandSuccess st cmdConnect :: ClientCommand String cmdConnect st networkStr = diff --git a/src/Client/Commands/DCC.hs b/src/Client/Commands/DCC.hs deleted file mode 100644 --- a/src/Client/Commands/DCC.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# Language OverloadedStrings #-} -{-| -Module : Client.Commands.DCC -Description : DCC command implementations -Copyright : (c) Eric Mertens, 2016-2020 -License : ISC -Maintainer : emertens@gmail.com --} - -module Client.Commands.DCC (dccCommands) where - -import Client.Commands.Arguments.Spec -import Client.Commands.Chat (cmdCtcp) -import Client.Commands.TabCompletion -import Client.Commands.Types -import Client.Configuration -import Client.State -import Client.State.DCC -import Client.State.Focus -import Control.Applicative -import qualified Control.Concurrent.Async as Async -import Control.Lens -import System.Directory (doesDirectoryExist) -import System.FilePath (()) - -dccCommands :: CommandSection -dccCommands = CommandSection "DCC" - - [ Command - (pure "dcc") - (liftA2 (,) (optionalArg (simpleToken "[accept|cancel|clear|resume]")) - optionalNumberArg) - "Main access to the DCC subsystem with the following subcommands:\n\n\ - \ /dcc : Access to a list of pending offer and downloads\n\ - \ /dcc accept #n : start downloading the #n pending offer\n\ - \ /dcc resume #n : same as accept but appending to the file on `download-dir`\n\ - \ /dcc clear #n : remove the #n offer from the list \n\ - \ /dcc cancel #n : cancel the download #n \n\n" - $ ClientCommand cmdDcc noClientTab - ] - --- | Implementation of @/dcc [(cancel|accept|resume)] [key] -cmdDcc :: ClientCommand (Maybe String, Maybe Int) -cmdDcc st (Nothing, Nothing) = commandSuccess (changeSubfocus FocusDCC st) -cmdDcc st (Just cmd, Just key) = checkAndBranch st cmd key -cmdDcc st _ = commandFailureMsg "Invalid syntax" st - -checkAndBranch :: ClientState -> String -> Int -> IO CommandResult -checkAndBranch st cmd key - | isCancel, NotExist <- curKeyStatus - = commandFailureMsg "No such DCC entry" st - | isCancel, curKeyStatus == Pending - = commandSuccess - $ set (clientDCC . dsOffers . ix key . dccStatus) UserKilled st - | isCancel, curKeyStatus /= Downloading - = commandFailureMsg "Transfer already stopped" st - | isCancel = Async.cancel threadId *> commandSuccess st - - | isClear, NotExist <- curKeyStatus - = commandFailureMsg "No such DCC entry" st - | isClear, curKeyStatus `elem` [Downloading, Pending] - = commandFailureMsg "Cancel the download first" st - | isClear = commandSuccess - $ set (clientDCC . dsOffers . at key) Nothing - $ set (clientDCC . dsTransfers . at key) Nothing st - - | isAcceptOrResume, curKeyStatus `elem` alreadyAcceptedSet - = commandFailureMsg "Offer already accepted" st - | isAcceptOrResume, NotExist <- curKeyStatus - = commandFailureMsg "No such DCC entry" st - | isAcceptOrResume - = do isDirectory <- doesDirectoryExist downloadPath - msize <- getFileOffset downloadPath - case (isDirectory, msize, cmd, mcs) of - (True, _, _, _) -> commandFailureMsg "DCC transfer would overwrite a directory" st - (_, Nothing, _, _) -> acceptOffer -- resume from 0 is accept - (_, _, "accept", _) -> acceptOffer -- overwrite file - (_, Just size, "resume", Just cs) -> resumeOffer size cs - _ -> commandFailureMsg "Unknown case" st - - | otherwise = commandFailureMsg "Invalid syntax" st - where - -- General - isAcceptOrResume = cmd `elem` ["accept", "resume"] - isCancel = cmd == "cancel" - isClear = cmd == "clear" - dccState = view clientDCC st - curKeyStatus = statusAtKey key dccState - alreadyAcceptedSet = [ CorrectlyFinished, UserKilled, LostConnection - , Downloading] - - -- For cancel, other cases handled on the guards - threadId = st ^?! clientDCC . dsTransfers . ix key . dtThread . _Just - - -- Common values for resume or accept - Just offer = view (clientDCC . dsOffers . at key) st -- guarded exist - updChan = view clientDCCUpdates st - downloadDir = view (clientConfig . configDownloadDir) st - downloadPath = downloadDir _dccFileName offer - mcs = preview (clientConnection (_dccNetwork offer)) st - - -- Actual workhorses for the commands - acceptOffer = - do newDCCState <- supervisedDownload downloadDir key updChan dccState - commandSuccess (set clientDCC newDCCState st) - - resumeOffer size cs = - let newOffer = offer { _dccOffset = size } - (target, txt) = resumeMsg size newOffer - st' = set (clientDCC . dsOffers . at key) (Just newOffer) st - in cmdCtcp cs st' (target, "DCC", txt) diff --git a/src/Client/Commands/Interpolation.hs b/src/Client/Commands/Interpolation.hs --- a/src/Client/Commands/Interpolation.hs +++ b/src/Client/Commands/Interpolation.hs @@ -83,8 +83,9 @@ <|> noMacroArguments <$ P.endOfInput where add1 desc = liftA2 (:) (simpleToken (Text.unpack desc)) + addBrackets desc = "[" <> desc <> "]" - addOpt var (MacroSpec rest) = MacroSpec (fromMaybe [] <$> optionalArg (add1 var rest)) + addOpt var (MacroSpec rest) = MacroSpec (fromMaybe [] <$> optionalArg (add1 (addBrackets var) rest)) addReq var (MacroSpec rest) = MacroSpec (add1 var rest) -- | Parse a 'Text' searching for the expansions as specified in diff --git a/src/Client/Commands/Operator.hs b/src/Client/Commands/Operator.hs --- a/src/Client/Commands/Operator.hs +++ b/src/Client/Commands/Operator.hs @@ -14,6 +14,7 @@ import Client.Commands.TabCompletion import Client.Commands.Types import Client.State.Network (sendMsg) +import Data.Maybe (fromMaybe) import qualified Data.Text as Text import Irc.Commands @@ -63,12 +64,24 @@ $ NetworkCommand cmdMasktrace simpleNetworkTab , Command + (pure "chantrace") + (simpleToken "channel") + "Outputs a list of channel members in etrace format.\n" + $ NetworkCommand cmdChantrace simpleNetworkTab + + , Command (pure "trace") - (optionalArg (liftA2 (,) (simpleToken "[server | nick]") (optionalArg (simpleToken "[server]")))) + (optionalArg (liftA2 (,) (simpleToken "[server|nick]") (optionalArg (simpleToken "[location]")))) "Outputs a list users on a server.\n" $ NetworkCommand cmdTrace simpleNetworkTab , Command + (pure "etrace") + (optionalArg (simpleToken "[-full|-v4|-v6|nick]")) + "Outputs a list users on a server.\n" + $ NetworkCommand cmdEtrace simpleNetworkTab + + , Command (pure "map") (pure ()) "Display network map.\n" @@ -104,6 +117,16 @@ cmdMasktrace :: NetworkCommand (String, String) cmdMasktrace cs st (mask, gecos) = do sendMsg cs (ircMasktrace (Text.pack mask) (Text.pack gecos)) + commandSuccess st + +cmdChantrace :: NetworkCommand String +cmdChantrace cs st chan = + do sendMsg cs (ircChantrace (Text.pack chan)) + commandSuccess st + +cmdEtrace :: NetworkCommand (Maybe String) +cmdEtrace cs st arg = + do sendMsg cs (ircEtrace (Text.pack (fromMaybe "" arg))) commandSuccess st cmdTrace :: NetworkCommand (Maybe (String, Maybe String)) diff --git a/src/Client/Commands/TabCompletion.hs b/src/Client/Commands/TabCompletion.hs --- a/src/Client/Commands/TabCompletion.hs +++ b/src/Client/Commands/TabCompletion.hs @@ -56,22 +56,38 @@ Bool {- ^ reversed order -} -> ClientState {- ^ client state -} -> IO CommandResult -simpleTabCompletion mode hints completions isReversed st = +simpleTabCompletion = simpleTabCompletion' (' ' /=) + +simpleTabCompletion' :: + Prefix a => + (Char -> Bool) {- ^ valid characters -} -> + WordCompletionMode {- ^ word completion mode -} -> + [a] {- ^ hints -} -> + [a] {- ^ all completions -} -> + Bool {- ^ reversed order -} -> + ClientState {- ^ client state -} -> + IO CommandResult +simpleTabCompletion' p mode hints completions isReversed st = case traverseOf clientTextBox tryCompletion st of Nothing -> commandFailure st Just st' -> commandSuccess st' where - tryCompletion = wordComplete mode isReversed hints completions + tryCompletion = wordComplete p mode isReversed hints completions -- | Complete the nickname at the current cursor position using the -- userlist for the currently focused channel (if any) nickTabCompletion :: Bool {- ^ reversed -} -> ClientState -> IO CommandResult nickTabCompletion isReversed st = - simpleTabCompletion mode hint completions isReversed st + simpleTabCompletion' isNickChar mode hint completions isReversed st where hint = activeNicks st completions = currentCompletionList st mode = currentNickCompletionMode st + +isNickChar :: Char -> Bool +isNickChar x = inrange 'a' 'z' || inrange 'A' 'Z' || inrange '0' '9' + || x `elem` "-[\\]^_`{}|#" + where inrange lo hi = lo <= x && x <= hi activeNicks :: ClientState -> diff --git a/src/Client/Commands/Toggles.hs b/src/Client/Commands/Toggles.hs --- a/src/Client/Commands/Toggles.hs +++ b/src/Client/Commands/Toggles.hs @@ -48,6 +48,11 @@ "Toggle multi-window layout mode.\n" $ ClientCommand cmdToggleLayout noClientTab + , Command + (pure "toggle-editor") + (pure ()) + "Toggle editor mode.\n" + $ ClientCommand cmdToggleEditor noClientTab ] cmdToggleDetail :: ClientCommand () @@ -67,3 +72,9 @@ where aux OneColumn = TwoColumn aux TwoColumn = OneColumn + +cmdToggleEditor :: ClientCommand () +cmdToggleEditor st _ = commandSuccess (over clientEditMode aux st) + where + aux SingleLineEditor = MultiLineEditor + aux MultiLineEditor = SingleLineEditor diff --git a/src/Client/Commands/Window.hs b/src/Client/Commands/Window.hs --- a/src/Client/Commands/Window.hs +++ b/src/Client/Commands/Window.hs @@ -13,12 +13,11 @@ import Client.Commands.TabCompletion import Client.Commands.Types import Client.Commands.WordCompletion -import Client.Image.PackedImage import Client.Mask (buildMask) import Client.State import Client.State.Focus import Client.State.Network -import Client.State.Window (emptyWindow, WindowLines((:-), Nil), wlFullImage, winMessages) +import Client.State.Window (windowClear, wlText, winMessages, winHidden, winSilent, winName) import Control.Applicative import Control.Exception import Control.Lens @@ -198,11 +197,13 @@ "Set the persistent regular expression.\n\ \\n\ \\^BFlags:\^B\n\ - \ -An Show n messages after match\n\ - \ -Bn Show n messages before match\n\ - \ -Cn Show n messages before and after match\n\ + \ -A n Show n messages after match\n\ + \ -B n Show n messages before match\n\ + \ -C n Show n messages before and after match\n\ + \ -F Use plain-text match instead of regular expression\n\ \ -i Case insensitive match\n\ \ -v Invert pattern match\n\ + \ -m n Limit results to n matches\n\ \ -- Stop processing flags\n\ \\n\ \Clear the regular expression by calling this without an argument.\n\ @@ -225,8 +226,76 @@ \the regular expression instead.\n" $ ClientCommand cmdMentions noClientTab + , Command + (pure "setwindow") + (simpleToken "hide|show|loud|silent") + "Set window property.\n\ + \\n\ + \\^Bloud\^B / \^Bsilent\^B\n\ + \ Toggles if window activity appears in the status bar.\n\ + \n\ + \\^Bshow\^B / \^Bhide\^B\n\ + \ Toggles if window appears in window command shortcuts.\n" + $ ClientCommand cmdSetWindow tabSetWindow + + , Command + (pure "setname") + (optionalArg (simpleToken "[letter]")) + "Set window shortcut letter. If no letter is provided the next available\n\ + \letter will automatically be assigned.\n\ + \\n\ + \Available letters are configured in the 'window-names' configuration setting.\n" + $ ClientCommand cmdSetWindowName noClientTab + ] +cmdSetWindowName :: ClientCommand (Maybe String) +cmdSetWindowName st arg = + -- unset current name so that it becomes available + let mbSt1 = failover (clientWindows . ix (view clientFocus st) . winName) (\_ -> Nothing) st in + case mbSt1 of + Nothing -> commandFailureMsg "no current window" st + Just st1 -> + let next = clientNextWindowName st + mbName = + case arg of + Just [n] | n `elem` clientWindowNames st -> Right n + Just _ -> Left "invalid name" + Nothing + | next /= '\0' -> Right next + | otherwise -> Left "no free names" in + case mbName of + Left e -> commandFailureMsg e st + Right name -> + let unset n = if n == Just name then Nothing else n in + commandSuccess + $ set (clientWindows . ix (view clientFocus st) . winName) (Just name) + $ over (clientWindows . each . winName) unset + $ st1 + +cmdSetWindow :: ClientCommand String +cmdSetWindow st cmd = + case mbFun of + Nothing -> commandFailureMsg "bad window setting" st + Just f -> + case failover (clientWindows . ix (view clientFocus st)) f st of + Nothing -> commandFailureMsg "no such window" st + Just st' -> commandSuccess st' + where + mbFun = + case cmd of + "show" -> Just (set winHidden False) + "hide" -> Just (set winName Nothing . set winHidden True) + "loud" -> Just (set winSilent False) + "silent" -> Just (set winSilent True) + _ -> Nothing + +tabSetWindow :: Bool {- ^ reversed -} -> ClientCommand String +tabSetWindow isReversed st _ = + simpleTabCompletion plainWordCompleteMode [] completions isReversed st + where + completions = ["hide", "show", "loud", "silent"] :: [Text] + -- | Implementation of @/grep@ cmdGrep :: ClientCommand String cmdGrep st str @@ -392,8 +461,8 @@ clearFocus1 focus st' = focusEffect (windowEffect st') where - windowEffect = set (clientWindows . at focus) - (if isActive then Just emptyWindow else Nothing) + windowEffect = over (clientWindows . at focus) + (if isActive then fmap windowClear else const Nothing) focusEffect | noChangeNeeded = id @@ -499,10 +568,8 @@ where focus = view clientFocus st - msgs = preview (clientWindows . ix focus . winMessages) st - outputLines = - case msgs of - Nothing -> [] - Just wls -> convert [] wls - convert acc Nil = acc - convert acc (wl :- wls) = convert (views wlFullImage imageText wl : acc) wls + + outputLines + = reverse + $ clientFilter st id + $ toListOf (clientWindows . ix focus . winMessages . each . wlText) st 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 @@ -17,6 +17,8 @@ , plainWordCompleteMode , defaultNickWordCompleteMode , slackNickWordCompleteMode + + , CaseText, caseText ) where import qualified Client.State.EditBox as Edit @@ -45,7 +47,6 @@ defaultNickWordCompleteMode :: WordCompletionMode defaultNickWordCompleteMode = WordCompletionMode "" ": " "" "" - -- | Word completion using a "@" prefix intended slackNickWordCompleteMode :: WordCompletionMode slackNickWordCompleteMode = WordCompletionMode "@" " " "@" "" @@ -62,13 +63,14 @@ -- completions. wordComplete :: Prefix a => + (Char -> Bool) {- ^ valid character predicate -} -> WordCompletionMode {- ^ leading update operation -} -> Bool {- ^ reversed -} -> [a] {- ^ priority completions -} -> [a] {- ^ possible completions -} -> Edit.EditBox -> Maybe Edit.EditBox -wordComplete mode isReversed hint vals box = - do let current = currentWord mode box +wordComplete p mode isReversed hint vals box = + do let current = currentWord p mode box guard (not (null current)) let cur = fromString current case view Edit.lastOperation box of @@ -76,7 +78,7 @@ | isPrefix pat cur -> do next <- tabSearch isReversed pat cur vals - Just $ replaceWith mode (toString next) box + Just $ replaceWith p mode (toString next) box where pat = fromString patternStr @@ -84,11 +86,11 @@ do next <- find (isPrefix cur) hint <|> tabSearch isReversed cur cur vals Just $ set Edit.lastOperation (Edit.TabOperation current) - $ replaceWith mode (toString next) box + $ replaceWith p mode (toString next) box -replaceWith :: WordCompletionMode -> String -> Edit.EditBox -> Edit.EditBox -replaceWith (WordCompletionMode spfx ssfx mpfx msfx) str box = - let box1 = Edit.killWordBackward False box +replaceWith :: (Char -> Bool) -> WordCompletionMode -> String -> Edit.EditBox -> Edit.EditBox +replaceWith p (WordCompletionMode spfx ssfx mpfx msfx) str box = + let box1 = Edit.killWordBackward (not . p) False box str1 | view Edit.pos box1 == 0 = spfx ++ str ++ ssfx | otherwise = mpfx ++ str ++ msfx in over Edit.content (Edit.insertString str1) box1 @@ -97,11 +99,11 @@ -- | Find the word preceeding the cursor skipping over any -- characters that can be found in the prefix and suffix for -- the current completion mode. -currentWord :: WordCompletionMode -> Edit.EditBox -> String -currentWord (WordCompletionMode spfx ssfx mpfx msfx) box +currentWord :: (Char -> Bool) -> WordCompletionMode -> Edit.EditBox -> String +currentWord p (WordCompletionMode spfx ssfx mpfx msfx) box = dropWhile (`elem`pfx) $ reverse - $ takeWhile (/= ' ') + $ takeWhile p $ dropWhile (`elem`sfx) $ reverse $ take n txt @@ -133,6 +135,18 @@ isPrefix = Text.isPrefixOf toString = Text.unpack +newtype CaseText = CaseText { unCaseText :: Text } + deriving (Eq, Ord, Show, Read) + +instance IsString CaseText where + fromString = CaseText . Text.toLower . Text.pack + +instance Prefix CaseText where + isPrefix x y = Text.isPrefixOf (unCaseText x) (unCaseText y) + toString = Text.unpack . unCaseText + +caseText :: Text -> CaseText +caseText = CaseText . Text.toLower -- | Find the next entry in a list of possible choices using an alphabetical -- ordering. diff --git a/src/Client/Commands/ZNC.hs b/src/Client/Commands/ZNC.hs --- a/src/Client/Commands/ZNC.hs +++ b/src/Client/Commands/ZNC.hs @@ -75,7 +75,7 @@ successZoned (fixDay t) -- explicit date and time - Just (dateStr, Just timeStr) + Just (timeStr, Just dateStr) | Just day <- parseFormats dateFormats dateStr , Just tod <- parseFormats timeFormats timeStr -> do tz <- getCurrentTimeZone diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -21,6 +21,7 @@ Configuration(..) , ConfigurationFailure(..) , LayoutMode(..) + , EditMode(..) , PaddingMode(..) , ExtensionConfiguration(..) @@ -30,10 +31,10 @@ , configPalette , configWindowNames , configNickPadding - , configDownloadDir , configMacros , configExtensions , configExtraHighlights + , configNeverHighlights , configUrlOpener , configIgnores , configActivityBar @@ -61,6 +62,10 @@ , FilePathContext , newFilePathContext , resolveFilePath + + -- * Url opener configuration + , UrlOpener(..) + , UrlArgument(..) ) where import Client.Commands.Interpolation @@ -74,14 +79,10 @@ import Config.Macro import Config.Schema import Control.Exception -import Control.Monad (unless) import Control.Lens hiding (List) -import Data.Foldable (toList) -import Data.Functor.Alt (()) +import Data.Foldable (foldl', toList) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.HashSet (HashSet) -import qualified Data.HashSet as HashSet import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe import Data.Monoid (Endo(..)) @@ -104,12 +105,12 @@ , _configServers :: (HashMap Text ServerSettings) -- ^ Host-specific settings , _configPalette :: Palette -- ^ User-customized color palette , _configWindowNames :: Text -- ^ Names of windows, used when alt-jumping) - , _configExtraHighlights :: HashSet Identifier -- ^ Extra highlight nicks/terms + , _configExtraHighlights :: [Identifier] -- ^ Extra highlight nicks/terms + , _configNeverHighlights :: [Identifier] -- ^ Never highlight nicks/terms , _configNickPadding :: PaddingMode -- ^ Padding of nicks in messages - , _configDownloadDir :: FilePath -- ^ Directory for downloads, default to HOME , _configMacros :: Recognizer Macro -- ^ command macros , _configExtensions :: [ExtensionConfiguration] -- ^ extensions to load - , _configUrlOpener :: Maybe FilePath -- ^ paths to url opening executable + , _configUrlOpener :: Maybe UrlOpener -- ^ paths to url opening executable , _configIgnores :: [Text] -- ^ initial ignore mask list , _configActivityBar :: Bool -- ^ initially visibility of the activity bar , _configBellOnMention :: Bool -- ^ notify terminal on mention @@ -121,6 +122,12 @@ } deriving Show +data UrlOpener = UrlOpener FilePath [UrlArgument] + deriving Show + +data UrlArgument = UrlArgLiteral String | UrlArgUrl + deriving Show + -- | Setting for how to pad the message prefix. data PaddingMode = LeftPadding !Int -- ^ Whitespace add to the left side of chat prefix @@ -135,6 +142,10 @@ | TwoColumn deriving Show +data EditMode + = SingleLineEditor + | MultiLineEditor + deriving Show -- | Failure cases when loading a configuration file. data ConfigurationFailure @@ -211,9 +222,7 @@ Left e -> throwIO $ ConfigurationMalformed path $ displayException e - Right cfg -> - do cfg' <- validateDirectories path (resolvePaths ctx (cfg defaultServerSettings (fpHome ctx))) - return (path, cfg') + Right cfg -> return (path, resolvePaths ctx (cfg defaultServerSettings)) badMacro :: FilePosition -> String -> IO a badMacro (FilePosition path posn) msg = @@ -233,31 +242,14 @@ . over (ssLogDir . mapped) res in over (configExtensions . mapped . extensionPath) res . over (configServers . mapped) resolveServerFilePaths - . over configDownloadDir res --- | Check if the `download-dir` is actually a directory and writeable, --- throw a ConfigurationMalformed exception if it isn't. -validateDirectories :: FilePath -> Configuration -> IO Configuration -validateDirectories cfgPath cfg = - do isDir <- doesDirectoryExist downloadPath - unless isDir $ throwIO (ConfigurationMalformed cfgPath noDirMsg) - isWriteable <- writable <$> getPermissions downloadPath - unless isWriteable - $ throwIO (ConfigurationMalformed cfgPath noWriteableMsg) - return cfg - where - downloadPath = view configDownloadDir cfg - noDirMsg = "The download-dir section doesn't point to a directory." - noWriteableMsg = "The download-dir doesn't point to a writeable directory." - configurationSpec :: - ValueSpec (ServerSettings -> FilePath -> Configuration) + ValueSpec (ServerSettings -> Configuration) configurationSpec = sectionsSpec "config-file" $ do let sec' def name spec info = fromMaybe def <$> optSection' name spec info - identifierSetSpec = HashSet.fromList <$> listSpec identifierSpec - ssDefUpdate <- sec' id "defaults" serverSpec + ssDefUpdate <- sec' (Nothing,id) "defaults" serverSpec "Default values for use across all server configurations" ssUpdates <- sec' [] "servers" (listSpec serverSpec) "Configuration parameters for IRC servers" @@ -271,10 +263,12 @@ "Programmable macro commands" _configExtensions <- sec' [] "extensions" (listSpec extensionSpec) "extension libraries to load at startup" - _configUrlOpener <- optSection' "url-opener" stringSpec + _configUrlOpener <- optSection' "url-opener" urlOpenerSpec "External command used by /url command" - _configExtraHighlights <- sec' mempty "extra-highlights" identifierSetSpec + _configExtraHighlights <- sec' mempty "extra-highlights" (listSpec identifierSpec) "Extra words to highlight in chat messages" + _configNeverHighlights <- sec' mempty "never-highlights" (listSpec identifierSpec) + "Words to avoid highlighting in chat messages" _configNickPadding <- sec' NoPadding "nick-padding" nickPaddingSpec "Amount of space to reserve for nicknames in chat messages" _configIgnores <- sec' [] "ignores" anySpec @@ -292,13 +286,10 @@ "Initial setting for window layout" _configShowPing <- sec' True "show-ping" yesOrNoSpec "Initial setting for visibility of ping times" - maybeDownloadDir <- optSection' "download-dir" stringSpec - "Path to DCC download directoy. Defaults to home directory." - return (\def home -> - let _configDefaults = ssDefUpdate def + return (\def -> + let _configDefaults = snd ssDefUpdate def _configServers = buildServerMap _configDefaults ssUpdates _configKeyMap = foldl (\acc f -> f acc) initialKeyMap bindings - _configDownloadDir = fromMaybe home maybeDownloadDir in Configuration{..}) -- | The default nick padding side if padding is going to be used @@ -468,17 +459,44 @@ RTLD_NOW <$ atomSpec "now" RTLD_LAZY <$ atomSpec "lazy" +urlOpenerSpec :: ValueSpec UrlOpener +urlOpenerSpec = simpleCase complexCase + where + simpleCase = + do path <- stringSpec + pure (UrlOpener path [UrlArgUrl]) + + complexCase = sectionsSpec "url-opener" $ + do path <- reqSection' "path" stringSpec "Executable" + args <- reqSection' "args" (listSpec argSpec) "Arguments" + pure (UrlOpener path args) + + argSpec = UrlArgUrl <$ atomSpec "url" + UrlArgLiteral <$> stringSpec + buildServerMap :: ServerSettings {- ^ defaults -} -> - [ServerSettings -> ServerSettings] -> + [(Maybe Text, ServerSettings -> ServerSettings)] -> HashMap Text ServerSettings -buildServerMap def ups = - HashMap.fromList [ (serverSettingName ss, ss) | up <- ups, let ss = up def ] +buildServerMap def ups = go HashMap.empty def Nothing where serverSettingName ss = fromMaybe (views ssHostName Text.pack ss) (view ssName ss) + raw = HashMap.fromListWith (++) [(mbExtName, [up]) | (mbExtName, up) <- ups] + + go acc prev prevName = foldl' (add prev) acc nexts + where + nexts = HashMap.findWithDefault [] prevName raw + + add prev acc f = go acc' ss (Just me) + where + ss = f prev + me = serverSettingName ss + acc' + | HashMap.member me acc = acc + | otherwise = HashMap.insert me ss acc data FilePathContext = FilePathContext { fpBase, fpHome :: FilePath } diff --git a/src/Client/Configuration/Colors.hs b/src/Client/Configuration/Colors.hs --- a/src/Client/Configuration/Colors.hs +++ b/src/Client/Configuration/Colors.hs @@ -19,7 +19,6 @@ import Config.Schema import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.Functor.Alt (()) import Data.Text (Text) import Graphics.Vty.Attributes @@ -52,8 +51,10 @@ blink <$ atomSpec "blink" bold <$ atomSpec "bold" dim <$ atomSpec "dim" + italic <$ atomSpec "italic" reverseVideo <$ atomSpec "reverse-video" standout <$ atomSpec "standout" + strikethrough<$ atomSpec "strikethrough" underline <$ atomSpec "underline" diff --git a/src/Client/Configuration/ServerSettings.hs b/src/Client/Configuration/ServerSettings.hs --- a/src/Client/Configuration/ServerSettings.hs +++ b/src/Client/Configuration/ServerSettings.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ApplicativeDo, TemplateHaskell, OverloadedStrings #-} +{-# LANGUAGE ApplicativeDo, TemplateHaskell, OverloadedStrings, RecordWildCards #-} {-| Module : Client.Configuration.ServerSettings @@ -87,13 +87,13 @@ import Control.Lens import Control.Monad ((>=>)) import qualified Data.ByteString as B -import Data.Functor.Alt (()) -import Data.List.NonEmpty (NonEmpty((:|))) import Data.ByteString (ByteString) -import Data.Monoid -import Data.Text (Text) +import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.List.NonEmpty as NonEmpty import Data.List.Split (chunksOf, splitOn) +import Data.Maybe (fromMaybe) +import Data.Monoid +import Data.Text (Text) import qualified Data.Text as Text import Irc.Identifier (Identifier, mkId) import Network.Socket (HostName, PortNumber) @@ -224,9 +224,11 @@ , _ssCapabilities = [] } -serverSpec :: ValueSpec (ServerSettings -> ServerSettings) +serverSpec :: ValueSpec (Maybe Text, ServerSettings -> ServerSettings) serverSpec = sectionsSpec "server-settings" $ - composeMaybe <$> sequenceA settings + do mbExt <- optSection "extends" "name of a server to use for defaults" + upd <- composeMaybe <$> sequenceA settings + pure (mbExt, upd) where composeMaybe :: [Maybe (a -> a)] -> a -> a @@ -413,6 +415,20 @@ nickCompletionSpec = defaultNickWordCompleteMode <$ atomSpec "default" slackNickWordCompleteMode <$ atomSpec "slack" + customNickCompletion + +customNickCompletion :: ValueSpec WordCompletionMode +customNickCompletion = + sectionsSpec "nick-completion" $ + do wcmStartPrefix <- fromMaybe "" <$> optSection' "start-prefix" stringSpec + "Prefix for nickname with when completing at start of line." + wcmStartSuffix <- fromMaybe "" <$> optSection' "start-suffix" stringSpec + "Suffix for nickname with when completing at start of line." + wcmMiddlePrefix <- fromMaybe "" <$> optSection' "middle-prefix" stringSpec + "Prefix for nickname with when completing in middle of line." + wcmMiddleSuffix <- fromMaybe "" <$> optSection' "middle-suffix" stringSpec + "Suffix for nickname with when completing in middle of line." + pure WordCompletionMode{..} identifierSpec :: ValueSpec Identifier diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -14,11 +14,12 @@ module Client.EventLoop ( eventLoop , updateTerminalSize + , ClientEvent(..) ) where -import Client.CApi (popTimer) +import Client.CApi (ThreadEntry, popTimer) import Client.Commands -import Client.Configuration (configJumpModifier, configKeyMap, configWindowNames, configDownloadDir) +import Client.Configuration (configJumpModifier, configKeyMap, configWindowNames) import Client.Configuration.ServerSettings import Client.EventLoop.Actions import Client.EventLoop.Errors (exceptionToLines) @@ -26,12 +27,12 @@ import Client.Hook import Client.Image import Client.Image.Layout (scrollAmount) +import Client.Image.StatusLine (clientTitle) import Client.Log import Client.Message import Client.Network.Async import Client.State -import Client.State.DCC -import qualified Client.State.EditBox as Edit +import qualified Client.State.EditBox as Edit import Client.State.Extensions import Client.State.Focus import Client.State.Network @@ -40,6 +41,7 @@ import Control.Lens import Control.Monad import Data.ByteString (ByteString) +import Data.Char (isSpace) import Data.Foldable import Data.Traversable import Data.List @@ -67,7 +69,7 @@ | NetworkEvents (NonEmpty (Text, NetworkEvent)) -- ^ Incoming network events | TimerEvent Text TimedAction -- ^ Timed action and the applicable network | ExtTimerEvent Int -- ^ extension ID - | DCCUpdate DCCUpdate -- ^ Event on any transfer + | ThreadEvent Int ThreadEntry -- | Block waiting for the next 'ClientEvent'. This function will compute @@ -78,7 +80,7 @@ IO ClientEvent getEvent vty st = do timer <- prepareTimer - atomically (asum [timer, vtyEvent, networkEvents, dccUpdate]) + atomically (asum [timer, vtyEvent, networkEvents, threadJoin]) where vtyEvent = VtyEvent <$> readTChan (_eventChannel (inputIface vty)) @@ -101,7 +103,9 @@ unless ready retry return event - dccUpdate = DCCUpdate <$> readTChan (view clientDCCUpdates st) + threadJoin = + do (i,r) <- readTQueue (view clientThreadJoins st) + pure (ThreadEvent i r) -- | Compute the earliest scheduled timed action for the client earliestEvent :: ClientState -> Maybe (UTCTime, ClientEvent) @@ -134,19 +138,20 @@ let (pic, st') = clientPicture (clientTick st) update vty pic + setWindowTitle vty (clientTitle st) event <- getEvent vty st' case event of ExtTimerEvent i -> eventLoop vty =<< clientExtTimer i st' + ThreadEvent i result -> + eventLoop vty =<< clientThreadJoin i result st' TimerEvent networkId action -> eventLoop vty =<< doTimerEvent networkId action st' VtyEvent vtyEvent -> traverse_ (eventLoop vty) =<< doVtyEvent vty vtyEvent st' NetworkEvents networkEvents -> eventLoop vty =<< foldM doNetworkEvent st' networkEvents - DCCUpdate upd -> - eventLoop vty =<< doDCCUpdate upd st' -- | Apply a single network event to the client state. doNetworkEvent :: ClientState -> (Text, NetworkEvent) -> IO ClientState @@ -320,10 +325,9 @@ , _msgBody = IrcBody irc' } - let (replies, dccUp, st3) = + let (replies, st3) = applyMessageToClientState time irc networkId cs st2 - traverse_ (atomically . writeTChan (view clientDCCUpdates st3)) dccUp traverse_ (sendMsg cs) replies clientResponse time' irc cs st3 @@ -344,7 +348,7 @@ case irc of Notice{} -> pure st1 - Reply RPL_STARTTLS _ -> + Reply _ RPL_STARTTLS _ -> do upgrade (view csSocket cs) pure (set ( clientConnections . ix network . csPingStatus . _PingConnecting . _3) @@ -435,8 +439,8 @@ -- edits ActKillHome -> changeEditor Edit.killHome ActKillEnd -> changeEditor Edit.killEnd - ActKillWordBack -> changeEditor (Edit.killWordBackward True) - ActKillWordForward -> changeEditor (Edit.killWordForward True) + ActKillWordBack -> changeEditor (Edit.killWordBackward isSpace True) + ActKillWordForward -> changeEditor (Edit.killWordForward isSpace True) ActYank -> changeEditor Edit.yank ActToggle -> changeContent Edit.toggle ActDelete -> changeContent Edit.delete @@ -446,6 +450,7 @@ ActBold -> changeEditor (Edit.insert '\^B') ActColor -> changeEditor (Edit.insert '\^C') ActItalic -> changeEditor (Edit.insert '\^]') + ActStrikethrough -> changeEditor (Edit.insert '\^^') ActUnderline -> changeEditor (Edit.insert '\^_') ActClearFormat -> changeEditor (Edit.insert '\^O') ActReverseVideo -> changeEditor (Edit.insert '\^V') @@ -465,6 +470,8 @@ ActNewerLine -> changeEditor $ \ed -> fromMaybe ed $ Edit.later ed ActScrollUp -> continue (scrollClient ( scrollAmount st) st) ActScrollDown -> continue (scrollClient (-scrollAmount st) st) + ActScrollUpSmall -> continue (scrollClient ( 3) st) + ActScrollDownSmall -> continue (scrollClient (-3) st) ActTabCompleteBack -> doCommandResult False =<< tabCompletion True st ActTabComplete -> doCommandResult False =<< tabCompletion False st @@ -518,24 +525,3 @@ traverseOf (clientConnection networkId) (applyTimedAction action) - -doDCCUpdate :: DCCUpdate -> ClientState -> IO ClientState -doDCCUpdate upd st0 = - case upd of - PercentUpdate k newVal -> return $ set (commonLens k . dtProgress) newVal st0 - SocketInterrupted k -> reportKill k LostConnection - UserInterrupted k -> reportKill k UserKilled - Finished k -> reportKill k CorrectlyFinished - accept@(Accept k _ _) -> - do let dccState0 = view clientDCC st0 - dccState1 = acceptUpdate accept dccState0 - -- st1 = set clientDCC dccState1 st0 - - updChan = view clientDCCUpdates st0 - mdir = view (clientConfig . configDownloadDir) st0 - - dccState2 <- supervisedDownload mdir k updChan dccState1 - return $ set clientDCC dccState2 st0 - where - reportKill k status = return $ over clientDCC (reportStopWithStatus k status) st0 - commonLens k = clientDCC . dsTransfers . at k . _Just diff --git a/src/Client/EventLoop/Actions.hs b/src/Client/EventLoop/Actions.hs --- a/src/Client/EventLoop/Actions.hs +++ b/src/Client/EventLoop/Actions.hs @@ -51,6 +51,8 @@ | ActNewerLine | ActScrollUp | ActScrollDown + | ActScrollUpSmall + | ActScrollDownSmall | ActBackWord | ActForwardWord @@ -65,6 +67,7 @@ | ActColor | ActItalic | ActUnderline + | ActStrikethrough | ActReverseVideo | ActClearFormat | ActInsertEnter @@ -75,7 +78,7 @@ | ActAdvanceNetwork | ActJumpToActivity | ActJumpPrevious - | ActJump Int + | ActJump Char | ActTabComplete | ActTabCompleteBack @@ -133,6 +136,7 @@ ,("bold" , (ActBold , [ctrl (KChar 'b')])) ,("color" , (ActColor , [ctrl (KChar 'c')])) ,("italic" , (ActItalic , [ctrl (KChar ']')])) + ,("strikethrough" , (ActStrikethrough , [ctrl (KChar '^')])) ,("underline" , (ActUnderline , [ctrl (KChar '_')])) ,("clear-format" , (ActClearFormat , [ctrl (KChar 'o')])) ,("reverse-video" , (ActReverseVideo , [ctrl (KChar 'v')])) @@ -157,6 +161,8 @@ ,("down" , (ActNewerLine , [norm KDown])) ,("scroll-up" , (ActScrollUp , [norm KPageUp])) ,("scroll-down" , (ActScrollDown , [norm KPageDown])) + ,("scroll-up-small" , (ActScrollUpSmall , [meta KPageUp])) + ,("scroll-down-small" , (ActScrollDownSmall , [meta KPageDown])) ,("enter" , (ActEnter , [norm KEnter])) ,("word-complete-back", (ActTabCompleteBack , [norm KBackTab])) ,("word-complete" , (ActTabComplete , [norm (KChar '\t')])) @@ -189,7 +195,7 @@ Action {- ^ action -} keyToAction _ jumpMods names mods (KChar c) | normalizeModifiers jumpMods == normalizeModifiers mods - , Just i <- Text.findIndex (c==) names = ActJump i + , Text.singleton c `Text.isInfixOf` names = ActJump c keyToAction m _ _ modifier key = case m ^. keyMapLens modifier key of Just a -> a @@ -229,6 +235,7 @@ , (KFun 3, ActCommand "toggle-activity-bar") , (KFun 4, ActCommand "toggle-metadata") , (KFun 5, ActCommand "toggle-layout") + , (KFun 6, ActCommand "toggle-editor") ]) : diff --git a/src/Client/EventLoop/Errors.hs b/src/Client/EventLoop/Errors.hs --- a/src/Client/EventLoop/Errors.hs +++ b/src/Client/EventLoop/Errors.hs @@ -58,7 +58,7 @@ explainHookupError e = case e of ConnectionFailure exs -> - "Connect failed" :| map explainIOError exs + "Connect failed" :| map displayException exs LineTooLong -> "IRC message too long" :| [] diff --git a/src/Client/EventLoop/Network.hs b/src/Client/EventLoop/Network.hs --- a/src/Client/EventLoop/Network.hs +++ b/src/Client/EventLoop/Network.hs @@ -41,7 +41,7 @@ clientResponse :: ZonedTime -> IrcMsg -> NetworkState -> ClientState -> IO ClientState clientResponse now irc cs st = case irc of - Reply RPL_WELCOME _ -> + Reply _ RPL_WELCOME _ -> -- run connection commands with the network focused and restore it afterward do let focus = NetworkFocus (view csNetwork cs) st' <- foldM (processConnectCmd now cs) @@ -50,7 +50,7 @@ return $! set clientFocus (view clientFocus st) st' -- Change focus when we get a message that we're being forwarded to another channel - Reply ERR_LINKCHANNEL (_ : src : dst : _) + Reply _ ERR_LINKCHANNEL (_ : src : dst : _) | let network = view csNetwork cs , view clientFocus st == ChannelFocus network (mkId src) -> return $! set clientFocus (ChannelFocus network (mkId dst)) st diff --git a/src/Client/Hook/Snotice.hs b/src/Client/Hook/Snotice.hs --- a/src/Client/Hook/Snotice.hs +++ b/src/Client/Hook/Snotice.hs @@ -84,6 +84,7 @@ (1, "k", [str|^[^ @]+@freenode/utility-bot/sigyn\{[^ ]+ added global [0-9]+ min. K-Line for |]), (1, "k", [str|^[^ @]+@freenode/bot/proxyscan\{[^ ]+ added global [0-9]+ min. K-Line for |]), (2, "k", [str|^[^ ]+ added global [0-9]+ min. K-Line for |]), + (2, "k", [str|^[^ ]+ added global [0-9]+ min. X-Line for |]), -- Global kline expiring, more complete regex: ^Propagated ban for \[[^ ]+\] expired$ (0, "k", [str|^Propagated ban for |]), -- Chancreate @@ -118,11 +119,15 @@ (3, "f", [str|^Failed (OPER|CHALLENGE) attempt|]), -- ORDER IMPORTANT - catch all failed attempts that aren't host mismatch (1, "k", [str|^KLINE active for|]), + (1, "k", [str|^XLINE active for|]), (3, "k", [str|^KLINE over-ruled for |]), (2, "k", [str|^[^ ]+ added global [0-9]+ min. K-Line from [^ ]+![^ ]+@[^ ]+\{[^ ]+\} for \[[^ ]+\] \[.*\]$|]), + (2, "k", [str|^[^ ]+ added global [0-9]+ min. X-Line from [^ ]+![^ ]+@[^ ]+\{[^ ]+\} for \[[^ ]+\] \[.*\]$|]), (2, "k", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} has removed the global K-Line for: \[.*\]$|]), (2, "k", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} has removed the temporary K-Line for: \[.*\]$|]), (2, "k", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} added temporary [0-9]+ min. D-Line for \[[^ ]+\] \[.*\]$|]), + (2, "k", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} has removed the X-Line for:|]), + (2, "k", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} is removing the X-Line for|]), (0, "m", [str|^Received SAVE message for|]), (0, "m", [str|^Ignored noop SAVE message for|]), @@ -174,6 +179,7 @@ (1, "o", [str|^Not kicking immune user |]), (1, "o", [str|^Not kicking oper |]), (1, "o", [str|^Overriding KICK from |]), + (1, "o", [str|^Overriding REMOVE from |]), (1, "o", [str|^Server [^ ]+ split from |]), (3, "o", [str|^Netsplit [^ ]+ <->|]), (2, "o", [str|^Remote SQUIT|]), @@ -199,6 +205,7 @@ (2, "o", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} added X-Line for \[.*\]|]), (2, "o", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} is adding a permanent RESV for \[.*\]|]), (2, "o", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} added RESV for \[.*\]|]), + (2, "o", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} has removed the RESV for:|]), (3, "o", [str|^[^ ]+ is an idiot\. Dropping |]), -- someone k-lined *@* (3, "o", [str|^Rejecting email for |]), -- registering from a badmailed address won't trigger this, emailing broken? (3, "o", [str|^ERROR |]), diff --git a/src/Client/Image.hs b/src/Client/Image.hs --- a/src/Client/Image.hs +++ b/src/Client/Image.hs @@ -18,15 +18,14 @@ Picture (..)) import Graphics.Vty.Image - -- | Generate a 'Picture' for the current client state. The resulting -- client state is updated for render specific information like scrolling. clientPicture :: ClientState -> (Picture, ClientState) clientPicture st = (pic, st') where - (pos, img, st') = clientImage st + (row, col, img, st') = clientImage st pic = Picture - { picCursor = AbsoluteCursor pos (view clientHeight st - 1) + { picCursor = AbsoluteCursor col (view clientHeight st - row) , picBackground = ClearBackground , picLayers = [img] } @@ -34,11 +33,11 @@ -- | Primary UI render logic clientImage :: ClientState {- ^ client state -} -> - (Int, Image, ClientState) {- ^ text box cursor position, image, updated state -} -clientImage st = (pos, img, st') + (Int, Int, Image, ClientState) {- ^ cursor row, cursor col, image, updated state -} +clientImage st = (row, col, img, st') where -- update client state for scroll clamp !st' = set clientTextBoxOffset nextOffset $ over clientScroll (max 0 . subtract overscroll) st - (overscroll, pos, nextOffset, img) = drawLayout st + (overscroll, row, col, nextOffset, img) = drawLayout st diff --git a/src/Client/Image/Layout.hs b/src/Client/Image/Layout.hs --- a/src/Client/Image/Layout.hs +++ b/src/Client/Image/Layout.hs @@ -24,7 +24,7 @@ -- | Compute the combined image for all the visible message windows. drawLayout :: ClientState {- ^ client state -} -> - (Int, Int, Int, Image) {- ^ overscroll, cursor pos, next offset, final image -} + (Int, Int, Int, Int, Image) {- ^ overscroll, cursor row, cursor col, next offset, final image -} drawLayout st = case view clientLayout st of TwoColumn | not (null extrafocus) -> drawLayoutTwo st extrafocus @@ -36,15 +36,15 @@ drawLayoutOne :: ClientState {- ^ client state -} -> [(Focus, Subfocus)] {- ^ extra windows -} -> - (Int, Int, Int, Image) {- ^ overscroll and final image -} + (Int, Int, Int, Int, Image) {- ^ overscroll and final image -} drawLayoutOne st extrafocus = - (overscroll, pos, nextOffset, output) + (overscroll, row, col, nextOffset, output) where w = view clientWidth st h:hs = splitHeights (rows - saveRows) (length extraLines) scroll = view clientScroll st - (overscroll, pos, nextOffset, main) = + (overscroll, row, col, nextOffset, main) = drawMain w (saveRows + h) scroll st output = vertCat $ reverse @@ -64,9 +64,9 @@ drawLayoutTwo :: ClientState {- ^ client state -} -> [(Focus, Subfocus)] {- ^ extra windows -} -> - (Int, Int, Int, Image) {- ^ overscroll, cursor pos, offset, final image -} + (Int, Int, Int, Int, Image) {- ^ overscroll, cursor row, cursor col, offset, final image -} drawLayoutTwo st extrafocus = - (overscroll, pos, nextOffset, output) + (overscroll, row, col, nextOffset, output) where [wl,wr] = divisions (view clientWidth st - 1) 2 hs = divisions (rows - length extraLines) (length extraLines) @@ -78,7 +78,7 @@ [ drawExtra st wr h' foc subfoc imgs | (h', (foc, subfoc, imgs)) <- zip hs extraLines] - (overscroll, pos, nextOffset, main) = + (overscroll, row, col, nextOffset, main) = drawMain wl rows scroll st pal = clientPalette st @@ -93,8 +93,8 @@ Int {- ^ draw height -} -> Int {- ^ scroll amount -} -> ClientState {- ^ client state -} -> - (Int,Int,Int,Image) -drawMain w h scroll st = (overscroll, pos, nextOffset, msgs <-> bottomImg) + (Int,Int,Int,Int,Image) +drawMain w h scroll st = (overscroll, row, col, nextOffset, msgs <-> bottomImg) where focus = view clientFocus st subfocus = view clientSubfocus st @@ -106,7 +106,7 @@ h' = max 0 (h - imageHeight bottomImg) bottomImg = statusLineImage w st <-> tbImage - (pos, nextOffset, tbImage) = textboxImage w st + (row, col, nextOffset, tbImage) = textboxImage 3 w st -- | Draw one of the extra windows from @/splits@ 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 @@ -1,4 +1,4 @@ -{-# Language OverloadedStrings, BangPatterns #-} +{-# Language OverloadedStrings, BangPatterns, ViewPatterns #-} {-| Module : Client.Image.Message Description : Renderer for message lines @@ -25,7 +25,9 @@ , nickPad , timeImage , drawWindowLine + , parseIrcTextWithNicks + , Highlight(..) ) where import Client.Configuration (PaddingMode(..)) @@ -34,15 +36,13 @@ import Client.Image.PackedImage import Client.Image.Palette import Client.Message -import Client.State.DCC (isSend) import Client.State.Window import Client.UserHost import Control.Lens import Data.Char import Data.Hashable (hash) import Data.HashMap.Strict (HashMap) -import Data.HashSet (HashSet) -import qualified Data.HashSet as HashSet +import qualified Data.HashMap.Strict as HashMap import Data.List import Data.Text (Text) import qualified Data.Text as Text @@ -60,8 +60,7 @@ data MessageRendererParams = MessageRendererParams { rendStatusMsg :: [Char] -- ^ restricted message sigils , rendUserSigils :: [Char] -- ^ sender sigils - , rendNicks :: HashSet Identifier -- ^ nicknames to highlight - , rendMyNicks :: HashSet Identifier -- ^ nicknames to highlight in red + , rendHighlights :: HashMap Identifier Highlight -- ^ words to highlight , rendPalette :: Palette -- ^ nick color palette , rendAccounts :: Maybe (HashMap Identifier UserAndHost) } @@ -71,8 +70,7 @@ defaultRenderParams = MessageRendererParams { rendStatusMsg = "" , rendUserSigils = "" - , rendNicks = HashSet.empty - , rendMyNicks = HashSet.empty + , rendHighlights = HashMap.empty , rendPalette = defaultPalette , rendAccounts = Nothing } @@ -110,6 +108,9 @@ cleanText :: Text -> Text cleanText = Text.map cleanChar +ctxt :: Text -> Image' +ctxt = text' defAttr . cleanText + errorPrefix :: MessageRendererParams -> Image' @@ -208,12 +209,12 @@ ircLinePrefix !rp body = let pal = rendPalette rp sigils = rendUserSigils rp - myNicks = rendMyNicks rp + hilites = rendHighlights rp rm = NormalRender who n = string (view palSigil pal) sigils <> ui where - baseUI = coloredUserInfo pal rm myNicks n + baseUI = coloredUserInfo pal rm hilites n ui = case rendAccounts rp of Nothing -> baseUI -- not tracking any accounts Just accts -> @@ -225,7 +226,7 @@ case mbAcct of Just acct | mkId acct == userNick n -> baseUI - | otherwise -> baseUI <> "(" <> text' defAttr (cleanText acct) <> ")" + | otherwise -> baseUI <> "(" <> ctxt acct <> ")" Nothing -> "~" <> baseUI in case body of @@ -236,14 +237,11 @@ Pong {} -> mempty Nick {} -> mempty - Topic src _ _ -> - who src <> " changed the topic:" - - Kick kicker _channel kickee _reason -> - who kicker <> - " kicked " <> - coloredIdentifier pal NormalIdentifier myNicks kickee <> - ":" + -- details in message part + Topic src _ _ -> who src + Kick src _ _ _ -> who src + Mode src _ _ -> who src + Invite src _ _ -> who src Notice src _ _ -> who src <> @@ -255,8 +253,6 @@ Ctcp src _dst "ACTION" _txt -> string (withForeColor defAttr blue) "* " <> who src - Ctcp src _dst "DCC" txt | isSend txt -> - who src <> " offers a DCC transfer" Ctcp {} -> mempty CtcpNotice src _dst _cmd _txt -> @@ -264,7 +260,7 @@ Error {} -> string (view palError pal) "ERROR" <> ":" - Reply code _ -> replyCodePrefix code + Reply _ code _ -> replyCodePrefix code UnknownMsg irc -> case view msgPrefix irc of @@ -274,8 +270,6 @@ Cap cmd -> text' (withForeColor defAttr magenta) (renderCapCmd cmd) <> ":" - Mode nick _ _ -> who nick <> " set mode:" - Authenticate{} -> "AUTHENTICATE" BatchStart{} -> mempty BatchEnd{} -> mempty @@ -291,8 +285,7 @@ IrcMsg -> Image' ircLineImage !rp body = let pal = rendPalette rp - myNicks = rendMyNicks rp - nicks = rendNicks rp + hilites = rendHighlights rp in case body of Join {} -> mempty @@ -306,27 +299,43 @@ Authenticate{} -> "***" Error txt -> parseIrcText txt - Topic _ _ txt -> parseIrcTextWithNicks pal myNicks nicks False txt - Kick _ _ _ txt -> parseIrcTextWithNicks pal myNicks nicks False txt - Notice _ _ txt -> parseIrcTextWithNicks pal myNicks nicks False txt - Privmsg _ _ txt -> parseIrcTextWithNicks pal myNicks nicks False txt - Wallops _ txt -> parseIrcTextWithNicks pal myNicks nicks False txt - Ctcp _ _ "ACTION" txt -> parseIrcTextWithNicks pal myNicks nicks False txt + Topic _ _ txt -> + "changed the topic: " <> + parseIrcTextWithNicks pal hilites False txt + + Kick _who _channel kickee reason -> + "kicked " <> + coloredIdentifier pal NormalIdentifier hilites kickee <> + ": " <> + parseIrcTextWithNicks pal hilites False reason + + Notice _ _ txt -> parseIrcTextWithNicks pal hilites False txt + Privmsg _ _ txt -> parseIrcTextWithNicks pal hilites False txt + Wallops _ txt -> parseIrcTextWithNicks pal hilites False txt + Ctcp _ _ "ACTION" txt -> parseIrcTextWithNicks pal hilites False txt Ctcp {} -> mempty CtcpNotice _ _ cmd txt -> parseIrcText cmd <> " " <> - parseIrcTextWithNicks pal myNicks nicks False txt + parseIrcTextWithNicks pal hilites False txt - Reply code params -> renderReplyCode pal NormalRender code params + Reply srv code params -> renderReplyCode pal NormalRender srv code params UnknownMsg irc -> - text' defAttr (view msgCommand irc) <> + ctxt (view msgCommand irc) <> char defAttr ' ' <> separatedParams (view msgParams irc) - Cap cmd -> text' defAttr (cleanText (capCmdText cmd)) - Mode _ _ params -> ircWords params + Cap cmd -> ctxt (capCmdText cmd) - Account _ acct -> if Text.null acct then "*" else text' defAttr (cleanText acct) - Chghost _ user host -> text' defAttr (cleanText user) <> " " <> text' defAttr (cleanText host) + Mode _ _ params -> + "set mode: " <> + ircWords params + Invite _ tgt chan -> + "invited " <> + coloredIdentifier pal NormalIdentifier hilites tgt <> + " to " <> ctxt (idText chan) + + Account _ acct -> if Text.null acct then "*" else ctxt acct + Chghost _ user host -> ctxt user <> " " <> ctxt host + -- | Render a chat message given a rendering mode, the sigils of the user -- who sent the message, and a list of nicknames to highlight. fullIrcLineImage :: @@ -336,11 +345,10 @@ let quietAttr = view palMeta pal pal = rendPalette rp sigils = rendUserSigils rp - myNicks = rendMyNicks rp - nicks = rendNicks rp + hilites = rendHighlights rp rm = DetailedRender - plainWho = coloredUserInfo pal rm myNicks + plainWho = coloredUserInfo pal rm hilites who n = -- sigils @@ -359,7 +367,7 @@ string quietAttr "nick " <> who old <> " is now known as " <> - coloredIdentifier pal NormalIdentifier myNicks new + coloredIdentifier pal NormalIdentifier hilites new Join nick _chan acct gecos -> string quietAttr "join " <> @@ -391,7 +399,7 @@ string quietAttr "kick " <> who kicker <> " kicked " <> - coloredIdentifier pal NormalIdentifier myNicks kickee <> + coloredIdentifier pal NormalIdentifier hilites kickee <> ": " <> parseIrcText reason @@ -401,27 +409,35 @@ " changed the topic: " <> parseIrcText txt + Invite src tgt chan -> + string quietAttr "invt " <> + who src <> + " invited " <> + coloredIdentifier pal NormalIdentifier hilites tgt <> + " to " <> + ctxt (idText chan) + Notice src _dst txt -> string quietAttr "note " <> who src <> string (withForeColor defAttr red) ": " <> - parseIrcTextWithNicks pal myNicks nicks False txt + parseIrcTextWithNicks pal hilites False txt Privmsg src _dst txt -> string quietAttr "chat " <> who src <> ": " <> - parseIrcTextWithNicks pal myNicks nicks False txt + parseIrcTextWithNicks pal hilites False txt Wallops src txt -> string quietAttr "wall " <> who src <> ": " <> - parseIrcTextWithNicks pal myNicks nicks False txt + parseIrcTextWithNicks pal hilites False txt Ctcp src _dst "ACTION" txt -> string quietAttr "actp " <> string (withForeColor defAttr blue) "* " <> who src <> " " <> - parseIrcTextWithNicks pal myNicks nicks False txt + parseIrcTextWithNicks pal hilites False txt Ctcp src _dst cmd txt -> string quietAttr "ctcp " <> @@ -447,20 +463,20 @@ string (view palError pal) "ERROR " <> parseIrcText reason - Reply code params -> - renderReplyCode pal DetailedRender code params + Reply srv code params -> + renderReplyCode pal DetailedRender srv code params UnknownMsg irc -> - foldMap (\ui -> coloredUserInfo pal rm myNicks ui <> char defAttr ' ') + foldMap (\ui -> coloredUserInfo pal rm hilites ui <> char defAttr ' ') (view msgPrefix irc) <> - text' defAttr (view msgCommand irc) <> + ctxt (view msgCommand irc) <> char defAttr ' ' <> separatedParams (view msgParams irc) Cap cmd -> text' (withForeColor defAttr magenta) (renderCapCmd cmd) <> - text' defAttr ": " <> - text' defAttr (cleanText (capCmdText cmd)) + ": " <> + ctxt (capCmdText cmd) Mode nick _chan params -> string quietAttr "mode " <> @@ -474,12 +490,12 @@ Account src acct -> string quietAttr "acct " <> who src <> ": " <> - if Text.null acct then "*" else text' defAttr (cleanText acct) + if Text.null acct then "*" else ctxt acct Chghost user newuser newhost -> string quietAttr "chng " <> who user <> ": " <> - text' defAttr (cleanText newuser) <> " " <> text' defAttr (cleanText newhost) + ctxt newuser <> " " <> ctxt newhost renderCapCmd :: CapCmd -> Text @@ -506,9 +522,7 @@ ircWords = mconcat . intersperse (char defAttr ' ') . map parseIrcText replyCodePrefix :: ReplyCode -> Image' -replyCodePrefix code = - text' attr (replyCodeText info) <> - char defAttr ':' +replyCodePrefix code = text' attr (replyCodeText info) <> ":" where info = replyCodeInfo code @@ -520,10 +534,10 @@ attr = withForeColor defAttr color -renderReplyCode :: Palette -> RenderMode -> ReplyCode -> [Text] -> Image' -renderReplyCode pal rm code@(ReplyCode w) params = +renderReplyCode :: Palette -> RenderMode -> Text -> ReplyCode -> [Text] -> Image' +renderReplyCode pal rm srv code@(ReplyCode w) params = case rm of - DetailedRender -> string attr (shows w " ") <> rawParamsImage + DetailedRender -> ctxt srv <> " " <> string attr (shows w " ") <> rawParamsImage NormalRender -> case code of RPL_WHOISUSER -> whoisUserParamsImage @@ -546,6 +560,50 @@ RPL_CREATIONTIME -> creationTimeParamsImage RPL_INVITING -> params_2_3_Image RPL_TESTLINE -> testlineParamsImage + RPL_STATSLINKINFO-> linkInfoParamsImage + RPL_STATSPLINE -> portParamsImage + RPL_STATSILINE -> authLineParamsImage + RPL_STATSDLINE -> dlineParamsImage + RPL_STATSQLINE -> banlineParamsImage "Q" + RPL_STATSXLINE -> banlineParamsImage "X" + RPL_STATSKLINE -> klineParamsImage + RPL_STATSCLINE -> connectLineParamsImage + RPL_STATSHLINE -> hubLineParamsImage + RPL_STATSCOMMANDS-> commandsParamsImage + RPL_STATSOLINE -> operLineParamsImage + RPL_STATSULINE -> sharedLineParamsImage + RPL_STATSYLINE -> classLineParamsImage + RPL_STATSDEBUG -> statsDebugParamsImage + RPL_HELPSTART -> statsDebugParamsImage + RPL_HELPTXT -> statsDebugParamsImage + RPL_TESTMASKGECOS-> testmaskGecosParamsImage + RPL_LOCALUSERS -> lusersParamsImage + RPL_GLOBALUSERS -> lusersParamsImage + RPL_LUSEROP -> params_2_3_Image + RPL_LUSERCHANNELS-> params_2_3_Image + RPL_ENDOFSTATS -> params_2_3_Image + RPL_AWAY -> awayParamsImage + RPL_TRACEUSER -> traceUserParamsImage + RPL_TRACEOPERATOR-> traceOperatorParamsImage + RPL_TRACESERVER -> traceServerParamsImage + RPL_TRACECLASS -> traceClassParamsImage + RPL_TRACELINK -> traceLinkParamsImage + RPL_TRACEUNKNOWN -> traceUnknownParamsImage + RPL_TRACECONNECTING -> traceConnectingParamsImage + RPL_TRACEHANDSHAKE -> traceHandShakeParamsImage + RPL_ETRACE -> etraceParamsImage + RPL_ETRACEFULL -> etraceFullParamsImage + RPL_ENDOFTRACE -> params_2_3_Image + RPL_ENDOFHELP -> params_2_3_Image + RPL_LIST -> listParamsImage + RPL_LINKS -> linksParamsImage + RPL_ENDOFLINKS -> params_2_3_Image + + ERR_NOPRIVS -> params_2_3_Image + ERR_HELPNOTFOUND -> params_2_3_Image + ERR_NEEDMOREPARAMS -> params_2_3_Image + ERR_NOSUCHNICK -> params_2_3_Image + ERR_NOSUCHSERVER -> params_2_3_Image _ -> rawParamsImage where label t = text' (view palLabel pal) t <> ": " @@ -568,24 +626,24 @@ params_2_3_Image = case params of - [_, p, _] -> parseIrcText' False p + [_, p, _] -> ctxt p _ -> rawParamsImage param_3_3_Image = case params of - [_, _, txt] -> parseIrcText' False txt + [_, _, txt] -> ctxt txt _ -> rawParamsImage param_3_4_Image = case params of - [_, _, p, _] -> parseIrcText' False p + [_, _, p, _] -> ctxt p _ -> rawParamsImage topicWhoTimeParamsImage = case params of [_, _, who, time] -> label "set by" <> - text' defAttr who <> + ctxt who <> label " at" <> string defAttr (prettyUnixTime (Text.unpack time)) _ -> rawParamsImage @@ -598,11 +656,11 @@ whoisUserParamsImage = case params of [_, nick, user, host, _, real] -> - text' (withStyle defAttr bold) nick <> + text' (withStyle defAttr bold) (cleanText nick) <> text' (view palLabel pal) "!" <> - parseIrcText' False user <> + ctxt user <> text' (view palLabel pal) "@" <> - parseIrcText' False host <> + ctxt host <> label " gecos" <> parseIrcText' False real _ -> rawParamsImage @@ -626,21 +684,327 @@ testlineParamsImage = case params of [_, name, mins, mask, msg] -> - text' defAttr name <> - label " duration" <> - string defAttr (prettyTime 60 (Text.unpack mins)) <> - label " mask" <> - text' defAttr mask <> - label " reason" <> - text' defAttr msg + ctxt name <> + label " duration" <> string defAttr (prettyTime 60 (Text.unpack mins)) <> + label " mask" <> ctxt mask <> + label " reason" <> ctxt msg _ -> rawParamsImage + linkInfoParamsImage = + case params of + [_, name, sendQ, sendM, sendK, recvM, recvK, Text.words -> conn : idle : caps] -> + ctxt name <> + label " sendQ" <> ctxt sendQ <> + label " sendM" <> ctxt sendM <> + label " sendK" <> ctxt sendK <> + label " recvM" <> ctxt recvM <> + label " recvK" <> ctxt recvK <> + label " since" <> string defAttr (prettyTime 1 (Text.unpack conn)) <> + label " idle" <> string defAttr (prettyTime 1 (Text.unpack idle)) <> + label " caps" <> ctxt (Text.unwords caps) + _ -> rawParamsImage + + authLineParamsImage = + case params of + [_, "I", name, pass, mask, port, klass] -> + ctxt name <> + (if pass == "" then mempty else label " pass" <> ctxt pass) <> + label " mask" <> ctxt mask' <> + (if port == "0" then mempty else label " port" <> ctxt port) <> + label " class" <> ctxt klass <> + (if null special then mempty else + label " special" <> ctxt (Text.unwords special)) + where + (mask', special) = parseILinePrefix mask + _ -> rawParamsImage + + banlineParamsImage expect = + case params of + [_, letter, hits, mask, reason] | letter == expect -> + ctxt mask <> + label " reason" <> ctxt reason <> + label " hits" <> ctxt hits + _ -> rawParamsImage + + testmaskGecosParamsImage = + case params of + [_, local, remote, mask, gecos, _txt] -> + ctxt mask <> + (if gecos == "*" then mempty else label " gecos" <> ctxt gecos) <> + label " local" <> ctxt local <> + label " remote" <> ctxt remote + _ -> rawParamsImage + + portParamsImage = + case params of + [_, "P", port, host, count, flags] -> + ctxt port <> + label " host" <> ctxt host <> + label " count" <> ctxt count <> + label " flags" <> ctxt flags + _ -> rawParamsImage + + dlineParamsImage = + case params of + [_, flag, host, reason] -> + ctxt flag <> + label " host:" <> ctxt host <> + label " reason" <> ctxt reason + _ -> rawParamsImage + + klineParamsImage = + case params of + [_, flag, host, "*", user, reason] -> + ctxt flag <> + label " host" <> ctxt host <> + (if user == "*" then mempty else label " user" <> ctxt user) <> + label " reason" <> ctxt reason + _ -> rawParamsImage + + statsDebugParamsImage = + case params of + [_, flag, txt] -> ctxt flag <> label " txt" <> ctxt txt + _ -> rawParamsImage + + lusersParamsImage = + case params of + [_, n, m, _txt] -> ctxt n <> label " max" <> ctxt m + _ -> rawParamsImage + + connectLineParamsImage = + case params of + [_, "C", mask, flagTxt, host, port, klass, certfp] -> + ctxt mask <> + label " host" <> ctxt host <> + label " port" <> ctxt port <> + label " class" <> ctxt klass <> + (if certfp == "*" then mempty else label " certfp" <> ctxt certfp) <> + (if null flags then mempty else label " flags" <> ctxt (Text.unwords flags)) + where + flags = parseCLineFlags flagTxt + [_, "C", mask, flagTxt, host, port, klass] -> + ctxt mask <> + label " host" <> ctxt host <> + label " port" <> ctxt port <> + label " class" <> ctxt klass <> + (if null flags then mempty else label " flags" <> ctxt (Text.unwords flags)) + where + flags = parseCLineFlags flagTxt + _ -> rawParamsImage + + hubLineParamsImage = + case params of + [_, "H", host, "*", server, "0", "-1"] -> + ctxt host <> label " server" <> ctxt server + [_, "H", host, "*", server] -> + ctxt host <> label " server" <> ctxt server + _ -> rawParamsImage + + commandsParamsImage = + case params of + [_, cmd, count, bytes, rcount] -> + ctxt cmd <> + label " count" <> ctxt count <> + label " bytes" <> ctxt bytes <> + label " remote-count" <> ctxt rcount + _ -> rawParamsImage + + operLineParamsImage = + case params of + [_, "O", mask, host, name, privset, "-1"] -> + ctxt mask <> + label " host" <> ctxt host <> + label " name" <> ctxt name <> + (if privset == "0" then mempty else label " privset" <> ctxt privset) + _ -> rawParamsImage + + sharedLineParamsImage = + case params of + [_, "U", server, mask, flags] -> + ctxt server <> + label " mask" <> ctxt mask <> + label " flags" <> ctxt flags + _ -> rawParamsImage + + classLineParamsImage = + case params of + [_, "Y", name, pingFreq, conFreq, maxUsers, maxSendq, maxLocal, maxGlobal, curUsers] -> + ctxt name <> + label " ping-freq" <> ctxt pingFreq <> + label " con-freq" <> ctxt conFreq <> + label " max-users" <> ctxt maxUsers <> + label " max-sendq" <> ctxt maxSendq <> + label " max-local" <> ctxt maxLocal <> + label " max-global" <> ctxt maxGlobal <> + label " current" <> ctxt curUsers + _ -> rawParamsImage + + awayParamsImage = + case params of + [_, nick, txt] -> ctxt nick <> label " msg" <> parseIrcText txt + _ -> rawParamsImage + + listParamsImage = + case params of + [_, chan, users, topic] -> + ctxt chan <> label " users" <> ctxt users <> label " topic" <> ctxt topic + _ -> rawParamsImage + + linksParamsImage = + case params of + [_, name, link, Text.breakOn " " -> (hops,location)] -> + ctxt name <> + label " link" <> ctxt link <> + label " hops" <> ctxt hops <> + label " location" <> ctxt (Text.drop 1 location) + _ -> rawParamsImage + + etraceParamsImage = + case params of + [_, kind, server, nick, user, host, ip, gecos] -> + ctxt nick <> "!" <> ctxt user <> "@" <> ctxt host <> + label " gecos" <> ctxt gecos <> + (if ip == "0" || ip == "255.255.255.255" then mempty else label " ip" <> ctxt ip) <> + label " server" <> ctxt server <> + label " kind" <> ctxt kind + _ -> rawParamsImage + + traceLinkParamsImage = + case params of + [_, "Link", version, nick, server] -> + ctxt server <> + label " nick" <> ctxt nick <> + label " version" <> ctxt version + _ -> rawParamsImage + + traceConnectingParamsImage = + case params of + [_, "Try.", klass, mask] -> ctxt mask <> label " class" <> ctxt klass + _ -> rawParamsImage + + traceHandShakeParamsImage = + case params of + [_, "H.S.", klass, mask] -> ctxt mask <> label " class" <> ctxt klass + _ -> rawParamsImage + + traceUnknownParamsImage = + case params of + [_, "????", klass, mask, ip, lastmsg] + | Text.length ip > 2 + , Text.head ip == '(' + , Text.last ip == ')' -> + ctxt mask <> + (if ip == "255.255.255.255" then mempty else + label " ip" <> ctxt (Text.tail (Text.init ip))) <> + label " class" <> ctxt klass <> + label " idle" <> string defAttr (prettyTime 1 (Text.unpack lastmsg)) + _ -> rawParamsImage + + traceServerParamsImage = + case params of + [_, "Serv", klass, servers, clients, link, who, lastmsg] + | not (Text.null servers), not (Text.null clients) + , Text.last servers == 'S', Text.last clients == 'C' -> + ctxt link <> + label " who" <> ctxt who <> + label " servers" <> ctxt (Text.init servers) <> + label " clients" <> ctxt (Text.init clients) <> + label " class" <> ctxt klass <> + label " idle" <> string defAttr (prettyTime 1 (Text.unpack lastmsg)) + _ -> rawParamsImage + + traceClassParamsImage = + case params of + [_, "Class", klass, count] -> + ctxt klass <> label " count" <> ctxt count + _ -> rawParamsImage + + traceUserParamsImage = + case params of + [_, "User", klass, mask, ip, lastpkt, lastmsg] + | Text.length ip > 2 + , Text.head ip == '(' + , Text.last ip == ')' -> + ctxt mask <> + (if ip == "255.255.255.255" then mempty else + label " ip" <> ctxt (Text.tail (Text.init ip))) <> + label " class" <> ctxt klass <> + label " pkt-idle" <> string defAttr (prettyTime 1 (Text.unpack lastpkt)) <> + label " msg-idle" <> string defAttr (prettyTime 1 (Text.unpack lastmsg)) + _ -> rawParamsImage + + traceOperatorParamsImage = + case params of + [_, "Oper", klass, mask, ip, lastpkt, lastmsg] + | Text.length ip > 2 + , Text.head ip == '(' + , Text.last ip == ')' -> + ctxt mask <> + (if ip == "255.255.255.255" then mempty else + label " ip" <> ctxt (Text.tail (Text.init ip))) <> + label " class" <> ctxt klass <> + label " pkt-idle" <> string defAttr (prettyTime 1 (Text.unpack lastpkt)) <> + label " msg-idle" <> string defAttr (prettyTime 1 (Text.unpack lastmsg)) + _ -> rawParamsImage + + etraceFullParamsImage = + case params of + [_, kind, klass, nick, user, host, ip, p1, p2, gecos] -> + ctxt nick <> "!" <> ctxt user <> "@" <> ctxt host <> + label " gecos" <> ctxt gecos <> + (if ip == "0" || ip == "255.255.255.255" then mempty else label " ip" <> ctxt ip) <> + label " kind" <> ctxt kind <> + label " class" <> ctxt klass <> + label " p1" <> ctxt p1 <> + label " p2" <> ctxt p2 + _ -> rawParamsImage + +parseCLineFlags :: Text -> [Text] +parseCLineFlags = go [] + where + go acc xs = + case Text.uncons xs of + Just (x, xs') -> + case getFlag x of + Nothing -> go (Text.singleton x:acc) xs' + Just flag -> go (flag:acc) xs' + Nothing -> reverse acc + + getFlag x = + case x of + 'A' -> Just "auto-connect" + 'M' -> Just "sctp" + 'S' -> Just "tls" + 'T' -> Just "topic-burst" + 'Z' -> Just "compressed" + _ -> Nothing + +parseILinePrefix :: Text -> (Text, [Text]) +parseILinePrefix = go [] + where + go special mask = + case Text.uncons mask of + Just (getSpecial -> Just s, mask') -> go (s:special) mask' + _ -> (mask, reverse special) + + getSpecial x = + case x of + '-' -> Just "no-tilde" + '+' -> Just "need-ident" + '=' -> Just "spoof-IP" + '|' -> Just "flood-exempt" + '$' -> Just "dnsbl-exempt" + '^' -> Just "kline-exempt" + '>' -> Just "limits-exempt" + _ -> Nothing + + -- | Transform string representing seconds in POSIX time to pretty format. prettyUnixTime :: String -> String prettyUnixTime str = case parseTimeM False defaultTimeLocale "%s" str of Nothing -> str - Just t -> formatTime defaultTimeLocale "%A %B %e, %Y %H:%M:%S %Z" (t :: UTCTime) + Just t -> formatTime defaultTimeLocale "%c" (t :: UTCTime) -- | Render string representing seconds into days, hours, minutes, and seconds. prettyTime :: Int -> String -> String @@ -667,14 +1031,14 @@ coloredIdentifier :: Palette {- ^ color palette -} -> IdentifierColorMode {- ^ draw mode -} -> - HashSet Identifier {- ^ my nicknames -} -> + HashMap Identifier Highlight {- ^ highlights -} -> Identifier {- ^ identifier to draw -} -> Image' -coloredIdentifier palette icm myNicks ident = - text' color (idText ident) +coloredIdentifier palette icm hilites ident = + text' color (cleanText (idText ident)) where color - | ident `HashSet.member` myNicks = + | Just HighlightMe == HashMap.lookup ident hilites = case icm of PrivmsgIdentifier -> view palSelfHighlight palette NormalIdentifier -> view palSelf palette @@ -690,14 +1054,14 @@ coloredUserInfo :: Palette {- ^ color palette -} -> RenderMode {- ^ mode -} -> - HashSet Identifier {- ^ my nicks -} -> + HashMap Identifier Highlight {- ^ highlights -} -> UserInfo {- ^ userinfo to draw-} -> Image' -coloredUserInfo palette NormalRender myNicks ui = - coloredIdentifier palette NormalIdentifier myNicks (userNick ui) -coloredUserInfo palette DetailedRender myNicks !ui = +coloredUserInfo palette NormalRender hilites ui = + coloredIdentifier palette NormalIdentifier hilites (userNick ui) +coloredUserInfo palette DetailedRender hilites !ui = mconcat - [ coloredIdentifier palette NormalIdentifier myNicks (userNick ui) + [ coloredIdentifier palette NormalIdentifier hilites (userNick ui) , aux '!' (userName ui) , aux '@' (userHost ui) ] @@ -705,42 +1069,49 @@ quietAttr = view palMeta palette aux x xs | Text.null xs = mempty - | otherwise = char quietAttr x <> text' quietAttr xs + | otherwise = char quietAttr x <> text' quietAttr (cleanText xs) -- | Render an identifier without using colors. This is useful for metadata. quietIdentifier :: Palette -> Identifier -> Image' quietIdentifier palette ident = - text' (view palMeta palette) (idText ident) + text' (view palMeta palette) (cleanText (idText ident)) +data Highlight + = HighlightMe + | HighlightNick + | HighlightError + | HighlightNone + deriving Eq + -- | Parse message text to construct an image. If the text has formatting -- control characters in it then the text will be rendered according to -- the formatting codes. Otherwise the nicknames in the message are -- highlighted. parseIrcTextWithNicks :: Palette {- ^ palette -} -> - HashSet Identifier {- ^ my nicks -} -> - HashSet Identifier {- ^ other nicks -} -> + HashMap Identifier Highlight {- ^ Highlights -} -> Bool {- ^ explicit controls rendering -} -> Text {- ^ input text -} -> Image' {- ^ colored text -} -parseIrcTextWithNicks palette myNick nicks explicit txt +parseIrcTextWithNicks palette hilite explicit txt | Text.any isControl txt = parseIrcText' explicit txt - | otherwise = highlightNicks palette myNick nicks txt + | otherwise = highlightNicks palette hilite txt -- | Given a list of nicknames and a chat message, this will generate -- an image where all of the occurrences of those nicknames are colored. highlightNicks :: Palette -> - HashSet Identifier {- ^ my nicks -} -> - HashSet Identifier {- ^ other nicks -} -> + HashMap Identifier Highlight {- ^ highlights -} -> Text -> Image' -highlightNicks palette myNicks nicks txt = foldMap highlight1 txtParts +highlightNicks palette hilites txt = foldMap highlight1 txtParts where txtParts = nickSplit txt - allNicks = HashSet.union myNicks nicks - highlight1 part - | HashSet.member partId allNicks = coloredIdentifier palette PrivmsgIdentifier myNicks partId - | otherwise = text' defAttr part + highlight1 part = + case HashMap.lookup partId hilites of + Nothing -> ctxt part + Just HighlightNone -> ctxt part + Just HighlightError -> text' (view palError palette) part + _ -> coloredIdentifier palette PrivmsgIdentifier hilites partId where partId = mkId part diff --git a/src/Client/Image/MircFormatting.hs b/src/Client/Image/MircFormatting.hs --- a/src/Client/Image/MircFormatting.hs +++ b/src/Client/Image/MircFormatting.hs @@ -20,7 +20,7 @@ ) where import Client.Image.PackedImage as I -import Control.Applicative ((<|>)) +import Control.Applicative ((<|>), empty) import Control.Lens import Data.Attoparsec.Text as Parse import Data.Bits @@ -30,6 +30,7 @@ import Graphics.Vty.Attributes import Data.Vector (Vector) import qualified Data.Vector as Vector +import Numeric (readHex) makeLensesFor [ ("attrForeColor", "foreColorLens") @@ -63,13 +64,21 @@ do rest <- pIrcLine explicit fmt return (text' fmt txt <> rest) Just (ControlSegment '\^C') -> - do (numberText, colorNumbers) <- match pColorNumbers + do (numberText, colorNumbers) <- match (pColorNumbers pColorNumber) rest <- pIrcLine explicit (applyColors colorNumbers fmt) return $ if explicit then controlImage '\^C' <> text' defAttr numberText <> rest else rest + Just (ControlSegment '\^D') -> + do (numberText, colorNumbers) <- match (pColorNumbers pColorHex) + rest <- pIrcLine explicit (applyColors colorNumbers fmt) + return $ if explicit + then controlImage '\^D' + <> text' defAttr numberText + <> rest + else rest Just (ControlSegment c) -- always render control codes that we don't understand | isNothing mbFmt' || explicit -> @@ -80,20 +89,28 @@ mbFmt' = applyControlEffect c fmt next = pIrcLine explicit (fromMaybe fmt mbFmt') -pColorNumbers :: Parser (Maybe (MaybeDefault Color, Maybe (MaybeDefault Color))) -pColorNumbers = option Nothing $ - do n <- pNumber - Just fc <- pure (mircColor n) - bc <- optional $ - do m <- Parse.char ',' *> pNumber - Just bc <- pure (mircColor m) - pure bc +pColorNumbers :: + Parser (MaybeDefault Color) -> + Parser (Maybe (MaybeDefault Color, Maybe (MaybeDefault Color))) +pColorNumbers color = option Nothing $ + do fc <- color + bc <- optional (Parse.char ',' *> color) return (Just (fc,bc)) +pColorNumber :: Parser (MaybeDefault Color) +pColorNumber = + do d1 <- digit + ds <- option [] (return <$> digit) + case mircColor (read (d1:ds)) of + Just c -> pure c + Nothing -> empty + +pColorHex :: Parser (MaybeDefault Color) +pColorHex = SetTo <$> (rgbColor' <$> p <*> p <*> p) where - pNumber = do d1 <- digit - ds <- option [] (return <$> digit) - return $! read (d1:ds) + p = do x <- satisfy isHexDigit + y <- satisfy isHexDigit + pure (fst (head (readHex [x,y]))) optional :: Parser a -> Parser (Maybe a) optional p = option Nothing (Just <$> p) @@ -147,6 +164,7 @@ applyControlEffect '\^B' attr = Just $! toggleStyle bold attr applyControlEffect '\^V' attr = Just $! toggleStyle reverseVideo attr applyControlEffect '\^_' attr = Just $! toggleStyle underline attr +applyControlEffect '\^^' attr = Just $! toggleStyle strikethrough attr applyControlEffect '\^]' attr = Just $! toggleStyle italic attr applyControlEffect '\^O' _ = Just defAttr applyControlEffect _ _ = Nothing diff --git a/src/Client/Image/Palette.hs b/src/Client/Image/Palette.hs --- a/src/Client/Image/Palette.hs +++ b/src/Client/Image/Palette.hs @@ -32,11 +32,13 @@ , palCommandPlaceholder , palCommandPrefix , palCommandError + , palCommandPrompt , palWindowDivider , palLineMarker , palCModes , palUModes , palSnomask + , palAway , paletteMap @@ -71,8 +73,10 @@ , _palCommandPrefix :: Attr -- ^ prefix of known command , _palCommandError :: Attr -- ^ unknown command , _palCommandPlaceholder :: Attr -- ^ command argument placeholder + , _palCommandPrompt :: Attr -- ^ Command input prefix @CMD:@ , _palWindowDivider :: Attr -- ^ Divider between split windows , _palLineMarker :: Attr -- ^ Divider between new and old messages + , _palAway :: Attr -- ^ color of nickname when away , _palCModes :: HashMap Char Attr -- ^ channel mode attributes , _palUModes :: HashMap Char Attr -- ^ user mode attributes , _palSnomask :: HashMap Char Attr -- ^ snotice mask attributes @@ -102,8 +106,10 @@ , _palCommandPrefix = withForeColor defAttr blue , _palCommandError = withForeColor defAttr red , _palCommandPlaceholder = withStyle defAttr reverseVideo + , _palCommandPrompt = defAttr `withStyle` bold `withBackColor` green `withForeColor` white , _palWindowDivider = withStyle defAttr reverseVideo , _palLineMarker = defAttr + , _palAway = withForeColor defAttr brightBlack , _palCModes = HashMap.empty , _palUModes = HashMap.empty , _palSnomask = HashMap.empty @@ -138,6 +144,8 @@ , ("command-placeholder", Lens palCommandPlaceholder) , ("command-prefix" , Lens palCommandPrefix) , ("command-error" , Lens palCommandError) + , ("command-prompt" , Lens palCommandPrompt) , ("window-divider" , Lens palWindowDivider) , ("line-marker" , Lens palLineMarker) + , ("away" , Lens palAway) ] 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 @@ -14,9 +14,10 @@ module Client.Image.StatusLine ( statusLineImage , minorStatusLineImage + , clientTitle ) where -import Client.Image.Message (cleanText) +import Client.Image.Message (cleanChar, cleanText) import Client.Image.PackedImage import Client.Image.Palette import Client.State @@ -31,11 +32,18 @@ import Data.HashMap.Strict (HashMap) import Data.Text (Text) import qualified Data.Text as Text +import qualified Data.Text.Lazy as LText import Graphics.Vty.Attributes import qualified Graphics.Vty.Image as Vty -import Irc.Identifier (Identifier, idText) +import Irc.Identifier (idText) import Numeric +clientTitle :: ClientState -> String +clientTitle st + = map cleanChar + $ LText.unpack + $ "glirc - " <> imageText (viewFocusLabel st (view clientFocus st)) + bar :: Image' bar = char (withStyle defAttr bold) '─' @@ -199,15 +207,17 @@ Vty.horizCat indicators Vty.<|> Vty.string defAttr "]" where - winNames = clientWindowNames st ++ repeat '?' - - indicators = foldr aux [] (zip winNames windows) + indicators = foldr aux [] windows windows = views clientWindows Map.elems st - aux (i,w) rest = + aux w rest = + let name = case view winName w of + Nothing -> '?' + Just i -> i in + if view winSilent w then rest else case view winMention w of - WLImportant -> Vty.char (view palMention pal) i : rest - WLNormal -> Vty.char (view palActivity pal) i : rest + WLImportant -> Vty.char (view palMention pal) name : rest + WLNormal -> Vty.char (view palActivity pal) name : rest WLBoring -> rest where pal = clientPalette st @@ -215,27 +225,28 @@ -- | Multi-line activity information enabled by F3 activityBarImages :: ClientState -> [Vty.Image] activityBarImages st - = catMaybes - $ zipWith baraux winNames - $ Map.toList + = mapMaybe baraux + $ Map.toAscList $ view clientWindows st where - - winNames = clientWindowNames st ++ repeat '?' - - baraux i (focus,w) + baraux (focus,w) + | view winSilent w = Nothing | n == 0 = Nothing -- todo: make configurable | otherwise = Just $ unpackImage bar Vty.<|> Vty.char defAttr '[' Vty.<|> - Vty.char (view palWindowName pal) i Vty.<|> - Vty.char defAttr ':' Vty.<|> - Vty.text' (view palLabel pal) focusText Vty.<|> + jumpLabel Vty.<|> + Vty.text' (view palLabel pal) (cleanText focusText) Vty.<|> Vty.char defAttr ':' Vty.<|> Vty.string attr (show n) Vty.<|> Vty.char defAttr ']' where + jumpLabel = + case view winName w of + Nothing -> mempty + Just name -> Vty.char (view palWindowName pal) name Vty.<|> + Vty.char defAttr ':' n = view winUnread w pal = clientPalette st attr = case view winMention w of @@ -275,32 +286,30 @@ myNickImage :: ClientState -> Vty.Image myNickImage st = case view clientFocus st of - NetworkFocus network -> nickPart network Nothing - ChannelFocus network chan -> nickPart network (Just chan) + NetworkFocus network -> nickPart network + ChannelFocus network _ -> nickPart network Unfocused -> Vty.emptyImage where pal = clientPalette st - nickPart network mbChan = + nickPart network = case preview (clientConnection network) st of Nothing -> Vty.emptyImage - Just cs -> Vty.string (view palSigil pal) myChanModes - Vty.<|> Vty.text' defAttr (idText nick) + Just cs -> Vty.text' attr (cleanText (idText nick)) Vty.<|> parens defAttr (unpackImage $ modesImage (view palUModes pal) (view csModes cs) <> snomaskImage) where + attr + | view csAway cs = view palAway pal + | otherwise = defAttr + nick = view csNick cs snomaskImage | null (view csSnomask cs) = "" | otherwise = " " <> modesImage (view palSnomask pal) (view csSnomask cs) - myChanModes = - case mbChan of - Nothing -> [] - Just chan -> view (csChannels . ix chan . chanUsers . ix nick) cs - modesImage :: HashMap Char Attr -> String -> Image' modesImage pal modes = "+" <> foldMap modeImage modes where @@ -313,19 +322,14 @@ pal = clientPalette st focusImage :: Focus -> ClientState -> Image' -focusImage focus st = infoBubble $ mconcat - [ char (view palWindowName pal) windowName - , char defAttr ':' - , viewFocusLabel st focus - ] +focusImage focus st = + infoBubble $ + case preview (clientWindows . ix focus . winName . _Just) st of + Nothing -> label + Just n -> char (view palWindowName pal) n <> ":" <> label where !pal = clientPalette st - windowNames = clientWindowNames st - - windowName = fromMaybe '?' - $ do i <- Map.lookupIndex focus (view clientWindows st) - preview (ix i) windowNames - + label = viewFocusLabel st focus parens :: Attr -> Vty.Image -> Vty.Image parens attr i = Vty.char attr '(' Vty.<|> i Vty.<|> Vty.char attr ')' @@ -337,20 +341,27 @@ Unfocused -> char (view palError pal) '*' NetworkFocus network -> - text' (view palLabel pal) network + text' (view palLabel pal) (cleanText network) ChannelFocus network channel -> - text' (view palLabel pal) network <> + text' (view palLabel pal) (cleanText network) <> char defAttr ':' <> - text' (view palLabel pal) (idText channel) <> - channelModesImage network channel st + string (view palSigil pal) (cleanChar <$> sigils) <> + text' (view palLabel pal) (cleanText (idText channel)) <> + channelModes -channelModesImage :: Text -> Identifier -> ClientState -> Image' -channelModesImage network channel st = - case preview (clientConnection network . csChannels . ix channel . chanModes) st of - Just modeMap | not (null modeMap) -> " " <> modesImage (view palCModes pal) (Map.keys modeMap) - _ -> mempty - where - pal = clientPalette st + where + (sigils, channelModes) = + case preview (clientConnection network) st of + Nothing -> ("", mempty) + Just cs -> + ( let nick = view csNick cs in + view (csChannels . ix channel . chanUsers . ix nick) cs + + , case preview (csChannels . ix channel . chanModes) cs of + Just modeMap | not (null modeMap) -> + " " <> modesImage (view palCModes pal) (Map.keys modeMap) + _ -> mempty + ) viewSubfocusLabel :: Palette -> Subfocus -> Maybe Image' viewSubfocusLabel pal subfocus = diff --git a/src/Client/Image/Textbox.hs b/src/Client/Image/Textbox.hs --- a/src/Client/Image/Textbox.hs +++ b/src/Client/Image/Textbox.hs @@ -21,32 +21,98 @@ import Client.Commands.Arguments.Parser import Client.Commands.Interpolation import Client.Commands.Recognizer +import Client.Image.LineWrap (fullLineWrap, terminate) import Client.Image.Message import Client.Image.MircFormatting import Client.Image.PackedImage import Client.Image.Palette import Client.State -import Client.State.Focus import qualified Client.State.EditBox as Edit import Control.Lens -import qualified Data.HashSet as HashSet -import Data.HashSet (HashSet) +import Data.HashMap.Strict (HashMap) import Data.List import qualified Data.Text as Text import Graphics.Vty.Attributes import qualified Graphics.Vty.Image as Vty import Irc.Identifier +textboxImage :: Int -> Int -> ClientState -> (Int, Int, Int, Vty.Image) -- ^ cursor column, new offset, image +textboxImage maxHeight width st = + case view clientEditMode st of + SingleLineEditor -> singleLineTextboxImage maxHeight width st + MultiLineEditor -> multiLineTextboxImage maxHeight width st + +multiLineTextboxImage :: Int -> Int -> ClientState -> (Int, Int, Int, Vty.Image) -- ^ cursor column, new offset, image +multiLineTextboxImage _maxHeight width st = (cursorRow, cursorCol, view clientTextBoxOffset st, output) + where + output = Vty.vertCat (terminate width . unpackImage <$> imgs) + + imgs = as ++ c ++ bs + + content = view (clientTextBox . Edit.content) st + + as = concatMap (fullLineWrap width) + $ mapHead (beginning <>) + $ map (<> plainText "\n") + $ rndr False <$> reverse (view Edit.above content) + + bs = concatMap (fullLineWrap width) + $ endAfters + $ rndr False <$> view Edit.below content + + cur = view Edit.line content + curTxt = view Edit.text cur + + cursorBase + = imageWidth $ parseIrcText' True + $ Text.pack + $ take (view Edit.pos cur) curTxt + + (cursorRow, cursorCol) = + calcCol (length c + length bs) c (if null as then 1 + cursorBase else cursorBase) + + c = fullLineWrap width + $ (if null as then beginning else mempty) + <> rndr True curTxt + <> (if null bs then ending else plainText "\n") + + rndr = renderLine st pal hilites macros + pal = clientPalette st + hilites = clientHighlightsFocus (view clientFocus st) st + macros = views (clientConfig . configMacros) (fmap macroSpec) st + + attr = view palTextBox pal + beginning = char attr '^' + ending = char attr '$' + + endAfters [] = [] + endAfters [x] = [x <> ending] + endAfters (x:xs) = x <> plainText "\n" : endAfters xs + + -- Using fullLineWrap make calculating the cursor much easier + -- to switch to word-breaking lineWrap we'll need some extra + -- logic to count skipped spaces. + calcCol row [] _ = (row, 0) + calcCol row (i:is) n + | n < w = (row, n) + | otherwise = calcCol (row-1) is (n-w) + where + w = imageWidth i + +mapHead :: (a -> a) -> [a] -> [a] +mapHead f (x:xs) = f x : xs +mapHead _ [] = [] + -- | Compute the UI image for the text input box. This computes -- the logical cursor position on the screen to compensate for -- VTY's cursor placement behavior. -textboxImage :: Int -> ClientState -> (Int, Int, Vty.Image) -- ^ cursor column, new offset, image -textboxImage width st - = (newPos, newOffset, croppedImage) +singleLineTextboxImage :: Int -> Int -> ClientState -> (Int, Int, Int, Vty.Image) -- ^ cursor column, new offset, image +singleLineTextboxImage _maxHeight width st + = (1, newPos, newOffset, croppedImage) where macros = views (clientConfig . configMacros) (fmap macroSpec) st (txt, content) = - renderContent st myNick nicks macros pal + renderContent st hilites macros pal (view (clientTextBox . Edit.content) st) lineImage = unpackImage (beginning <> content <> ending) @@ -76,14 +142,7 @@ beginning = char attr '^' ending = char attr '$' - - (myNick,nicks) = - case view clientFocus st of - ChannelFocus network channel -> - (clientHighlightsNetwork network st, - HashSet.fromList (channelUserList network channel st) - ) - _ -> (HashSet.empty, HashSet.empty) + hilites = clientHighlightsFocus (view clientFocus st) st -- | Renders the whole, uncropped text box as well as the 'String' @@ -91,13 +150,12 @@ -- the logical cursor position of the cropped version of the text box. renderContent :: ClientState {- ^ client state -} -> - HashSet Identifier {- ^ my nicknames -} -> - HashSet Identifier {- ^ other nicknames -} -> + HashMap Identifier Highlight {- ^ highlights -} -> Recognizer MacroSpec {- ^ macro completions -} -> Palette {- ^ palette -} -> Edit.Content {- ^ content -} -> (Int, Image') {- ^ left-of-cursor width, image rendering -} -renderContent st myNick nicks macros pal c = (leftLen, wholeImg) +renderContent st hilites macros pal c = (leftLen, wholeImg) where as = reverse (view Edit.above c) bs = view Edit.below c @@ -111,7 +169,7 @@ + sum (map imageWidth leftImgs) + imageWidth (parseIrcText' True (Text.pack leftCur)) - rndr = renderLine st pal myNick nicks macros + rndr = renderLine st pal hilites macros leftImgs = map (rndr False) as @@ -127,13 +185,12 @@ renderLine :: ClientState -> Palette -> - HashSet Identifier -> - HashSet Identifier -> + HashMap Identifier Highlight -> Recognizer MacroSpec {- ^ commands -} -> Bool {- ^ focused -} -> String {- ^ input text -} -> Image' {- ^ output image -} -renderLine st pal myNick nicks macros focused input = +renderLine st pal hilites macros focused input = case span (' '==) input of (spcs, '/':xs) -> string defAttr spcs <> char defAttr '/' @@ -149,7 +206,7 @@ allCommands = (Left <$> macros) <> (Right <$> commands) (attr, continue) - = case recognize (Text.pack cmd) allCommands of + = case recognize (Text.toLower (Text.pack cmd)) allCommands of Exact (Right Command{cmdArgumentSpec = spec}) -> ( specAttr spec , render pal st focused spec @@ -160,10 +217,10 @@ ) Prefix _ -> ( view palCommandPrefix pal - , parseIrcTextWithNicks pal myNick nicks focused . Text.pack + , parseIrcTextWithNicks pal hilites focused . Text.pack ) Invalid -> ( view palCommandError pal - , parseIrcTextWithNicks pal myNick nicks focused . Text.pack + , parseIrcTextWithNicks pal hilites focused . Text.pack ) - _ -> parseIrcTextWithNicks pal myNick nicks focused (Text.pack input) + _ -> parseIrcTextWithNicks pal hilites focused (Text.pack input) diff --git a/src/Client/Log.hs b/src/Client/Log.hs --- a/src/Client/Log.hs +++ b/src/Client/Log.hs @@ -59,20 +59,21 @@ renderLogLine :: ClientMessage {- ^ message -} -> FilePath {- ^ log directory -} -> + [Char] {- ^ status modes -} -> Identifier {- ^ target -} -> Maybe LogLine -renderLogLine !msg dir target = +renderLogLine !msg dir statusModes target = case view msgBody msg of NormalBody{} -> Nothing ErrorBody {} -> Nothing IrcBody irc -> case irc of Privmsg who _ txt -> - success (L.fromChunks ["<", idText (userNick who), "> ", cleanText txt]) + success (L.fromChunks (statuspart ["<", idText (userNick who), "> ", cleanText txt])) Notice who _ txt -> - success (L.fromChunks ["-", idText (userNick who), "- ", cleanText txt]) + success (L.fromChunks (statuspart ["-", idText (userNick who), "- ", cleanText txt])) Ctcp who _ "ACTION" txt -> - success (L.fromChunks ["* ", idText (userNick who), " ", cleanText txt]) + success (L.fromChunks (statuspart ["* ", idText (userNick who), " ", cleanText txt])) _ -> Nothing where @@ -87,3 +88,6 @@ , logTarget = Text.toLower (idTextNorm target) , logLine = L.fromChunks ["[", Text.pack todStr, "] "] <> txt <> "\n" } + statuspart rest + | null statusModes = rest + | otherwise = "statusmsg(" : Text.pack statusModes : ") " : rest diff --git a/src/Client/Message.hs b/src/Client/Message.hs --- a/src/Client/Message.hs +++ b/src/Client/Message.hs @@ -39,7 +39,6 @@ import Irc.Identifier import Irc.UserInfo import Irc.Codes -import Client.State.DCC (isSend) data MessageBody = IrcBody !IrcMsg @@ -94,10 +93,9 @@ Privmsg who _ _ -> ChatSummary who Notice who _ _ -> ChatSummary who Ctcp who _ "ACTION" _ -> ChatSummary who - Ctcp who _ "DCC" txt | isSend txt -> DccSendSummary (userNick who) Ctcp who _ _ _ -> CtcpSummary (userNick who) CtcpNotice who _ _ _ -> ChatSummary who - Reply code _ -> ReplySummary code + Reply _ code _ -> ReplySummary code Account who _ -> AcctSummary (userNick who) Chghost who _ _ -> ChngSummary (userNick who) _ -> NoSummary diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -20,8 +20,7 @@ , clientTextBox , clientTextBoxOffset , clientConnections - , clientDCC - , clientDCCUpdates + , clientThreadJoins , clientWidth , clientHeight , clientEvents @@ -44,9 +43,11 @@ , clientActivityReturn , clientErrorMsg , clientLayout + , clientEditMode , clientRtsStats , clientConfigPath , clientStsPolicy + , clientHighlights -- * Client operations , withClientState @@ -54,7 +55,6 @@ , clientFilter , buildMatcher , clientToggleHideMeta - , clientHighlightsNetwork , channelUserList , consumeInput @@ -66,13 +66,13 @@ , addConnection , removeNetwork , clientTick - , queueDCCTransfer , applyMessageToClientState - , clientHighlights + , clientHighlightsFocus , clientWindowNames , clientPalette , clientAutoconnects , clientActiveCommand + , clientNextWindowName , clientExtraFocuses , currentNickCompletionMode @@ -126,7 +126,6 @@ import Client.State.Focus import Client.State.Network import Client.State.Window -import Client.State.DCC import ContextFilter import Control.Applicative import Control.Concurrent.MVar @@ -173,8 +172,7 @@ , _clientConnections :: !(HashMap Text NetworkState) -- ^ state of active connections , _clientEvents :: !(TQueue NetworkEvent) -- ^ incoming network event queue - , _clientDCC :: !DCCState -- ^ DCC subsystem - , _clientDCCUpdates :: !(TChan DCCUpdate) -- ^ DCC update events + , _clientThreadJoins :: TQueue (Int, ThreadEntry) -- ^ Finished threads ready to report , _clientConfig :: !Configuration -- ^ client configuration , _clientConfigPath :: !FilePath -- ^ client configuration file path @@ -189,7 +187,8 @@ , _clientActivityBar :: !Bool -- ^ visible activity bar , _clientShowPing :: !Bool -- ^ visible ping time , _clientRegex :: Maybe Matcher -- ^ optional persistent filter - , _clientLayout :: !LayoutMode -- ^ layout mode for split screen + , _clientLayout :: LayoutMode -- ^ layout mode for split screen + , _clientEditMode :: EditMode -- ^ editor rendering mode , _clientBell :: !Bool -- ^ sound a bell next draw @@ -202,11 +201,13 @@ , _clientRtsStats :: Maybe Stats -- ^ most recent GHC RTS stats , _clientStsPolicy :: !(HashMap Text StsPolicy) -- ^ STS policy entries + , _clientHighlights :: !(HashMap Identifier Highlight) -- ^ highlights } data Matcher = Matcher { matcherBefore :: !Int , matcherAfter :: !Int + , matcherMax :: Maybe Int , matcherPred :: LText.Text -> Bool } @@ -250,7 +251,7 @@ withExtensionState $ \exts -> do events <- atomically newTQueue - dccEvents <- atomically newTChan + threadQueue <- atomically newTQueue sts <- readPolicyFile let ignoreIds = map mkId (view configIgnores cfg) k ClientState @@ -258,8 +259,7 @@ , _clientIgnores = HashSet.fromList ignoreIds , _clientIgnoreMask = buildMask ignoreIds , _clientConnections = _Empty # () - , _clientDCC = emptyDCCState - , _clientDCCUpdates = dccEvents + , _clientThreadJoins = threadQueue , _clientTextBox = Edit.defaultEditBox , _clientTextBoxOffset = 0 , _clientWidth = 80 @@ -276,6 +276,7 @@ , _clientDetailView = False , _clientRegex = Nothing , _clientLayout = view configLayout cfg + , _clientEditMode = SingleLineEditor , _clientActivityBar = view configActivityBar cfg , _clientShowPing = view configShowPing cfg , _clientBell = False @@ -284,6 +285,7 @@ , _clientErrorMsg = Nothing , _clientRtsStats = Nothing , _clientStsPolicy = sts + , _clientHighlights = HashMap.empty } withExtensionState :: (ExtensionState -> IO a) -> IO a @@ -325,7 +327,7 @@ ClientState -> ClientState recordChannelMessage network channel msg st - = recordLogLine msg channel + = recordLogLine msg statusModes channel' $ recordWindowLine focus wl st where focus = ChannelFocus network channel' @@ -334,8 +336,7 @@ rendParams = MessageRendererParams { rendStatusMsg = statusModes , rendUserSigils = computeMsgLineSigils network channel' msg st - , rendNicks = HashSet.fromList (channelUserList network channel' st) - , rendMyNicks = highlights + , rendHighlights = highlights , rendPalette = clientPalette st , rendAccounts = accounts } @@ -345,7 +346,7 @@ possibleStatusModes = view csStatusMsg cs (statusModes, channel') = splitStatusMsgModes possibleStatusModes channel importance = msgImportance msg st - highlights = clientHighlightsNetwork network st + highlights = clientHighlightsFocus (ChannelFocus network channel) st accounts = if view (csSettings . ssShowAccounts) cs @@ -355,14 +356,15 @@ recordLogLine :: ClientMessage {- ^ message -} -> + [Char] {- ^ status modes -} -> Identifier {- ^ target -} -> ClientState {- ^ client state -} -> ClientState -recordLogLine msg target st = +recordLogLine msg statusModes target st = case view (clientConnection (view msgNetwork msg) . csSettings . ssLogDir) st of Nothing -> st Just dir -> - case renderLogLine msg dir target of + case renderLogLine msg dir statusModes target of Nothing -> st Just ll -> over clientLogQueue (cons ll) st @@ -383,10 +385,10 @@ msgImportance msg st = let network = view msgNetwork msg me = preview (clientConnection network . csNick) st - highlights = clientHighlightsNetwork network st + highlights = clientHighlightsFocus (NetworkFocus network) st isMe x = Just x == me checkTxt txt - | any (\x -> HashSet.member (mkId x) highlights) + | any (\x -> Just HighlightMe == HashMap.lookup (mkId x) highlights) (nickSplit txt) = WLImportant | otherwise = WLNormal in @@ -416,11 +418,11 @@ Error{} -> WLImportant -- channel information - Reply RPL_TOPIC _ -> WLBoring - Reply RPL_INVITING _ -> WLBoring + Reply _ RPL_TOPIC _ -> WLBoring + Reply _ RPL_INVITING _ -> WLBoring -- remaining replies go to network window - Reply cmd _ -> + Reply _ cmd _ -> case replyCodeType (replyCodeInfo cmd) of ErrorReply -> WLImportant _ -> WLNormal @@ -471,8 +473,7 @@ (addToWindow wl) st') st chans where - cfg = view clientConfig st - wl = toWindowLine' cfg WLBoring msg + wl = toWindowLine' network st WLBoring msg chans = user : case preview (clientConnection network . csChannels) st of Nothing -> [] @@ -518,7 +519,7 @@ case view msgBody msg of ErrorBody txt -> err txt IrcBody (Error txt) -> err txt - IrcBody (Reply code args) + IrcBody (Reply _ code args) | let info = replyCodeInfo code , ErrorReply <- replyCodeType info -> err (Text.intercalate " " (replyCodeText info : drop 1 args)) @@ -534,9 +535,7 @@ focus | Text.null network = Unfocused | otherwise = NetworkFocus (view msgNetwork msg) importance = msgImportance msg st - wl = toWindowLine' cfg importance msg - - cfg = view clientConfig st + wl = toWindowLine' network st importance msg recordError :: ZonedTime {- ^ now -} -> @@ -551,6 +550,14 @@ , _msgBody = ErrorBody msg } +clientNextWindowName :: ClientState -> Char +clientNextWindowName st = + case clientWindowNames st \\ usedNames of + [] -> '\0' + c:_ -> c + where + usedNames = toListOf (clientWindows . folded . winName . _Just) st + -- | Record window line at the given focus creating the window if necessary recordWindowLine :: Focus -> @@ -559,7 +566,11 @@ ClientState recordWindowLine focus wl st = st2 where - freshWindow = emptyWindow { _winHideMeta = view (clientConfig . configHideMeta) st } + freshWindow = emptyWindow + { _winName' = clientNextWindowName st + , _winHideMeta = view (clientConfig . configHideMeta) st + } + st1 = over (clientWindows . at focus) (\w -> Just $! addToWindow wl (fromMaybe freshWindow w)) st @@ -587,11 +598,11 @@ (prefix, image, full) = msgImage (view msgTime msg) params (view msgBody msg) -- | 'toWindowLine' but with mostly defaulted parameters. -toWindowLine' :: Configuration -> WindowLineImportance -> ClientMessage -> WindowLine -toWindowLine' config = +toWindowLine' :: Text -> ClientState -> WindowLineImportance -> ClientMessage -> WindowLine +toWindowLine' network st = toWindowLine defaultRenderParams - { rendPalette = view configPalette config - , rendMyNicks = view configExtraHighlights config + { rendPalette = view (clientConfig . configPalette) st + , rendHighlights = clientHighlightsFocus (NetworkFocus network) st } @@ -668,18 +679,23 @@ clientFilter st f xs = case clientMatcher st of Nothing -> xs - Just m -> + Just m -> + limit $ filterContext (matcherAfter m) -- client messages are stored in descending order (matcherBefore m) (matcherPred m . f) xs + where + limit = maybe id take (matcherMax m) data MatcherArgs = MatcherArgs { argAfter :: !Int , argBefore :: !Int , argInvert :: !Bool , argSensitive :: !Bool + , argMax :: Maybe Int + , argPlain :: !Bool } defaultMatcherArgs :: MatcherArgs @@ -688,6 +704,8 @@ , argBefore = 0 , argInvert = False , argSensitive = True + , argMax = Nothing + , argPlain = False } buildMatcher :: String -> Maybe Matcher @@ -697,20 +715,29 @@ case dropWhile (' '==) reStr of '-' : 'i' : ' ' : reStr' -> go args{argSensitive=False} reStr' '-' : 'v' : ' ' : reStr' -> go args{argInvert=True} reStr' + '-' : 'F' : ' ' : reStr' -> go args{argPlain=True} reStr' '-' : 'A' : reStr' | [(a,' ':reStr'')] <- reads reStr', a>=0 -> go args{argAfter=a} reStr'' '-' : 'B' : reStr' | [(b,' ':reStr'')] <- reads reStr', b>=0 -> go args{argBefore=b} reStr'' '-' : 'C' : reStr' | [(c,' ':reStr'')] <- reads reStr', c>=0 -> go args{argAfter=c,argBefore=c} reStr'' + '-' : 'm' : reStr' | [(m,' ':reStr'')] <- reads reStr', m>=0 -> go args{argMax=Just m} reStr'' '-' : '-' : ' ' : reStr' -> finish args reStr' _ -> finish args reStr - finish args reStr = - case compile defaultCompOpt{caseSensitive=argSensitive args} - defaultExecOpt{captureGroups=False} - reStr of - Left{} -> Nothing - Right r - | argInvert args -> Just (Matcher (argBefore args) (argAfter args) (not . matchTest r . LText.unpack)) - | otherwise -> Just (Matcher (argBefore args) (argAfter args) ( matchTest r . LText.unpack)) + finish args reStr + | argPlain args = + if argSensitive args + then matcher (LText.isInfixOf (LText.fromStrict (Text.pack reStr))) + else matcher (LText.isInfixOf (LText.fromStrict (Text.toLower (Text.pack reStr))) . LText.toLower) + | otherwise = + case compile defaultCompOpt{caseSensitive=argSensitive args} + defaultExecOpt{captureGroups=False} + reStr of + Left{} -> Nothing + Right r -> matcher (matchTest r . LText.unpack) + where + matcher f + | argInvert args = Just (Matcher (argBefore args) (argAfter args) (argMax args) (not . f)) + | otherwise = Just (Matcher (argBefore args) (argAfter args) (argMax args) f) -- | Compute the command and arguments currently in the textbox. clientActiveCommand :: @@ -821,29 +848,13 @@ Text {- ^ network name -} -> NetworkState {- ^ network connection state -} -> ClientState {- ^ client state -} -> - ([RawIrcMsg], Maybe DCCUpdate, ClientState) {- ^ response , DCC updates, updated state -} + ([RawIrcMsg], ClientState) {- ^ response , DCC updates, updated state -} applyMessageToClientState time irc network cs st = - cs' `seq` (reply, dccUp, st') + cs' `seq` (reply, st') where Apply reply cs' = applyMessage time irc cs - (st', dccUp) = queueDCCTransfer network irc - $ applyWindowRenames network irc - $ set (clientConnections . ix network) cs' st - --- | Queue a DCC transfer when the message is correct. Await for user --- confirmation to start the download. -queueDCCTransfer :: Text -> IrcMsg -> ClientState - -> (ClientState, Maybe DCCUpdate) -queueDCCTransfer network ctcpMsg st - | Just (fromU, _target, command, txt) <- ctcpToTuple ctcpMsg - , command == "DCC", dccState <- view clientDCC st - = case (parseSEND network fromU txt, parseACCEPT dccState fromU txt) of - (Right offer, _) -> (set clientDCC (insertAsNewMax offer dccState) st, Nothing) - (_, Just upd) -> (st, Just upd) - (_, _) -> (st, Nothing) - - | otherwise = (st, Nothing) - + st' = applyWindowRenames network irc + $ set (clientConnections . ix network) cs' st -- | When a nick change happens and there is an open query window for that nick -- and there isn't an open query window for the new nick, rename the window. @@ -907,20 +918,22 @@ Just focus -> changeFocus focus st Nothing -> st where - windowList = views clientWindows Map.toAscList st + windowList = filter (not . view winSilent . snd) + $ views clientWindows Map.toAscList st highPriority = find (\x -> WLImportant == view winMention (snd x)) windowList lowPriority = find (\x -> view winUnread (snd x) > 0) windowList --- | Jump the focus directly to a window based on its zero-based index. +-- | Jump the focus directly to a window based on its zero-based index +-- while ignoring hidden windows. jumpFocus :: - Int {- ^ zero-based window index -} -> + Char {- ^ window name -} -> ClientState -> ClientState -jumpFocus i st - | 0 <= i, i < Map.size windows = changeFocus focus st - | otherwise = st +jumpFocus i st = + case find p (Map.assocs (view clientWindows st)) of + Nothing -> st + Just (focus,_) -> changeFocus focus st where - windows = view clientWindows st - (focus,_) = Map.elemAt i windows + p (_, w) = view winName w == Just i -- | Change the window focus to the given value, reset the subfocus @@ -1031,29 +1044,40 @@ Just k -> changeFocus k st Nothing -> st where - (l,r) = Map.split (view clientFocus st) (view clientWindows st) + (l,r) = Map.split (view clientFocus st) + $ Map.filter (views winHidden not) + $ view clientWindows st --- | Compute the set of extra identifiers that should be highlighted given --- a particular network state. -clientHighlights :: - NetworkState {- ^ network state -} -> - ClientState {- ^ client state -} -> - HashSet Identifier {- ^ extra highlight identifiers -} -clientHighlights cs st = - HashSet.insert - (view csNick cs) - (view (clientConfig . configExtraHighlights) st) +clientHighlightsFocus :: + Focus -> + ClientState -> + HashMap Identifier Highlight +clientHighlightsFocus focus st = + case focus of + ChannelFocus n c -> netcase n (Just c) + NetworkFocus n -> netcase n Nothing + Unfocused -> base + where + base = HashMap.fromList [(x, HighlightMe) | x <- view (clientConfig . configExtraHighlights) st] + <> HashMap.fromList [(x, HighlightNone) | x <- view (clientConfig . configNeverHighlights) st] + <> view clientHighlights st --- | Compute the set of extra identifiers that should be highlighted given --- a particular network. -clientHighlightsNetwork :: - Text {- ^ network -} -> - ClientState {- ^ client state -} -> - HashSet Identifier {- ^ extra highlight identifiers -} -clientHighlightsNetwork network st = - case preview (clientConnection network) st of - Just cs -> clientHighlights cs st - Nothing -> view (clientConfig . configExtraHighlights) st + replace x y = + case x of + HighlightError -> y + _ -> x + + netcase n mbC = + case preview (clientConnection n) st of + Nothing -> view clientHighlights st + Just cs -> + HashMap.unionWith + replace + (HashMap.insert (view csNick cs) HighlightMe base) + (HashMap.fromList [(u, HighlightNick) + | Just c <- [mbC] + , u <- views (csChannels . ix c . chanUsers) HashMap.keys cs + , Text.length (idText u) > 1 ]) -- | Produce the list of window names configured for the client. clientWindowNames :: diff --git a/src/Client/State/DCC.hs b/src/Client/State/DCC.hs deleted file mode 100644 --- a/src/Client/State/DCC.hs +++ /dev/null @@ -1,356 +0,0 @@ -{-# Language TemplateHaskell, OverloadedStrings, BangPatterns - , ScopedTypeVariables, TypeApplications #-} - -{-| -Module : Client.State.DCC -Description : CTCP DCC transfer handling -Copyright : (c) Ruben Astudillo, 2019 -License : ISC -Maintainer : ruben.astud@gmail.com - -This module provides ADTs and functions to deal with DCC SEND/ACCEPT -request and how start such transfers. --} - -module Client.State.DCC - ( - DCCState(..) - , dsOffers - , dsTransfers - , emptyDCCState - -- * DCC offers - , DCCOffer(..) - , dccNetwork - , dccFromInfo - , dccFromIP - , dccPort - , dccFileName - , dccSize - , dccOffset - , dccStatus - -- * DCC transfer - , DCCTransfer(..) - , dtThread - , dtProgress - , ConnectionStatus(..) - -- * DCC Update - , DCCUpdate(..) - -- * Transfer a DCCOffer - , supervisedDownload - -- * Parser for DCC request - , parseSEND - , parseACCEPT - -- * DCC RESUME functionality - , resumeMsg - , acceptUpdate - -- * Miscellaneous - , getFileOffset - , insertAsNewMax - , ctcpToTuple - , statusAtKey - , reportStopWithStatus - , isSend - ) where - -import Control.Applicative (Alternative(..)) -import Control.Concurrent.Async -import Control.Concurrent.STM -import Control.Exception (bracket, IOException) -import qualified Control.Exception as E -import Control.Lens hiding (from) -import Control.Monad (unless, when) -import Data.Attoparsec.Text -import qualified Data.ByteString as B -import Data.ByteString.Builder (word32BE, toLazyByteString) -import Data.ByteString.Lazy (toStrict) -import Data.IntMap (Key, IntMap) -import qualified Data.IntMap as I hiding (size, empty) -import Data.List (find) -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Word (Word32, Word64) -import Hookup -import Irc.Identifier (Identifier, idText) -import Irc.Message (IrcMsg(..)) -import Irc.UserInfo (UserInfo(..), uiNick) -import Network.Socket (HostName, PortNumber, hostAddressToTuple) -import System.FilePath ((), takeFileName) -import System.IO (withFile, IOMode(..), openFile, hClose, hFileSize) - --- | All the necessary information to start the download -data DCCOffer = DCCOffer - { _dccNetwork :: !Text - , _dccFromInfo :: !UserInfo - , _dccFromIP :: HostName -- ^ String of the IPv4 representation - , _dccPort :: !PortNumber - , _dccFileName :: FilePath -- ^ Guaranteed to be just the name - , _dccSize :: !Word32 -- ^ Size of the whole file, per protocol - -- restricted to 32-bits - , _dccOffset :: !Word32 -- ^ Byte from where the transmission starts - , _dccStatus :: !ConnectionStatus - } deriving (Show, Eq) - --- | Status of a connection at certain @Key@ -data ConnectionStatus - = CorrectlyFinished | UserKilled | LostConnection | Downloading | Pending - | NotExist - deriving (Eq, Show) - --- | Structure with information of a download accepted via "/dcc accept" --- or "/dcc resume" -data DCCTransfer = DCCTransfer - { _dtThread :: !(Maybe (Async ())) -- ^ If Nothing, the thread was killed - -- and stopped. - , _dtProgress :: !Word32 -- ^ Percentage of progress - } - --- Check the invariants at @statusAtKey@ -data DCCState = DCCState - { _dsOffers :: !(IntMap DCCOffer) - , _dsTransfers :: !(IntMap DCCTransfer) - } - -data DCCUpdate - = PercentUpdate !Key !Word32 - | Finished !Key - | SocketInterrupted !Key - | UserInterrupted !Key - | Accept !Key !PortNumber !Word32 -- update that DCC RESUME triggers - deriving (Show, Eq) -- Word32 is the offset - -makeLenses ''DCCOffer -makeLenses ''DCCTransfer -makeLenses ''DCCState - -emptyDCCState :: DCCState -emptyDCCState = DCCState mempty mempty - --- | Smart constructor for new DCCOffers. -dccOffer :: Text -> UserInfo -> HostName -> PortNumber - -> FilePath -> Word32 -> DCCOffer -dccOffer network userFrom hostaddr port filename filesize = - DCCOffer network userFrom hostaddr port filename filesize 0 Pending - --- | Launch a supervisor thread for downloading the offer referred by @Key@ and --- return the DCCState accordingly. -supervisedDownload :: - FilePath -> - Key -> - TChan DCCUpdate -> - DCCState -> - IO DCCState -supervisedDownload dir key updChan state = do - let Just offer = view (dsOffers . at key) state -- Previously check - supervisorThread <- async $ - withAsync (startDownload dir key updChan offer) $ \realTransferThread -> - do upd <- E.catches (Finished key <$ wait realTransferThread) - [ E.Handler (\(_ :: IOException) -> - return (SocketInterrupted key)) - -- exception thrown by cancel on async >= 2.2 - , E.Handler (\(_ :: AsyncCancelled) -> - return (UserInterrupted key)) - ] - atomically (writeTChan updChan upd) - let startPercent = percent (_dccOffset offer) (_dccSize offer) - newTransfer = DCCTransfer (Just supervisorThread) startPercent - newOffer = offer { _dccStatus = Downloading } - newState = set (dsOffers . at key) (Just newOffer) - $ set (dsTransfers . at key) (Just newTransfer) state - return newState - --- | -startDownload :: FilePath -> Key -> TChan DCCUpdate -> DCCOffer -> IO () -startDownload dir key updChan offer@(DCCOffer _ _ from port name totalSize offset _) = do - let openMode = if offset > 0 then AppendMode else WriteMode - filepath = dir name - bracket (connect param) close $ \conn -> - bracket (openFile filepath openMode) hClose $ \hdl -> - do -- Has to decouple @send@ from @recv@, tells how much - -- have we downloaded. - recvChan1 <- atomically newTChan - recvChan2 <- atomically (dupTChan recvChan1) - - -- Two threads, one for @send@ the progress to the - -- server and another to signal how much progress - -- have we done to the main thread. `withAsync` guarantee - -- correct exception handling when the user cancels the - -- transfer. - -- Notice how recvSendLoop starts at offset instead of 0, this - -- is so DCC RESUME start acknowledgement as if the starting - -- size was recently @recv@. DCC is a mess. - withAsync (sendStream totalSize conn recvChan1) - $ \outThread -> withAsync (report offer key recvChan2 updChan) - $ \_reportThread -> do recvSendLoop offset recvChan1 conn hdl - wait outThread - where - param = ConnectionParams - { cpBind = Just "0.0.0.0" -- only support IPv4 - , cpHost = from - , cpPort = port - , cpSocks = Nothing - , cpTls = Nothing } - - buffSize = 4 * 1024 * 1024 - - recvSendLoop size chan conn hdl = - do bytes <- recv conn buffSize - unless (B.null bytes) $ - do B.hPut hdl bytes - let newSize = size + fromIntegral (B.length bytes) - atomically (writeTChan chan newSize) - recvSendLoop newSize chan conn hdl - - --- | @send@ing the current size to the fileserver. As an independent --- acknowledgement stream, it doesn't match the protocol, but matches --- what other clients and servers do in practice. -sendStream :: Word32 -> Connection -> TChan Word32 -> IO () -sendStream maxSize conn chan = - do val <- atomically (readTChan chan) - let valBE = toStrict (toLazyByteString (word32BE val)) - send conn valBE - unless (val >= maxSize) (sendStream maxSize conn chan) - --- | Generate @PercentUpdate@ for each percent of download. -report :: DCCOffer -> Key -> TChan Word32 -> TChan DCCUpdate -> IO () -report offer key input output = compareAndUpdate (percent offset totalsize) - where - offset = _dccOffset offer - totalsize = _dccSize offer - - compareAndUpdate :: Word32 -> IO () - compareAndUpdate prevPercent = - do curSize <- atomically $ readTChan input - let curPercent = percent curSize totalsize - updateEv = PercentUpdate key curPercent - if curPercent == 100 - then atomically (writeTChan output updateEv) - else do when (curPercent > prevPercent) - (atomically (writeTChan output updateEv)) - compareAndUpdate curPercent - --- Avoid overflow via Word64 -percent :: Word32 -> Word32 -> Word32 -percent a total = fromIntegral (fromIntegral a * 100 `div` fromIntegral total :: Word64) - --- | This function can only be called after a @cancel@ has been issued --- on the supervisor thread at @Key@ -reportStopWithStatus :: Key -> ConnectionStatus -> DCCState -> DCCState -reportStopWithStatus key newstatus - = set (dsOffers . ix key . dccStatus) newstatus - . set (dsTransfers . ix key . dtThread ) Nothing - --- | Parse a "DCC SEND" command. -parseSEND :: Text -> UserInfo -> Text -> Either String DCCOffer -parseSEND network userFrom = parseOnly (sendFormat network userFrom) - -sendFormat :: Text -> UserInfo -> Parser DCCOffer -sendFormat network userFrom = - do name <- string "SEND" *> space *> nameFormat - addr <- ipv4Dotted <$ space <*> decimal - port <- space *> decimal - totalsize <- space *> decimal - return (dccOffer network userFrom addr port name totalsize) - --- | Parse a "DCC RESUME" command. -parseACCEPT :: DCCState -> UserInfo -> Text -> Maybe DCCUpdate -parseACCEPT state userFrom text = - case parseOnly acceptFormat text of - Left _ -> Nothing - Right (fileName, port, offset) -> - do (key, _) <- find (predicate fileName) offerList - return (Accept key port offset) - where - offerList = I.toDescList (_dsOffers state) - - predicate fileName (key, offer) = - view dccFileName offer == fileName && - view dccFromInfo offer == userFrom && - statusAtKey key state == Pending - - -acceptFormat :: Parser (FilePath, PortNumber, Word32) -acceptFormat = - do filepath <- string "ACCEPT" *> space *> nameFormat - port <- space *> decimal - offset <- space *> decimal - return (filepath, port, offset) - --- Depending on the software, if the filename contains no spaces, the --- DCC SEND can be sent without a \" enclosing it. Handle that --- correctly. -nameFormat :: Parser FilePath -nameFormat = do textPath <- try quotedName <|> noSpaceName - return (takeFileName (Text.unpack textPath)) - where - quotedName = char '\"' *> takeWhile1 ('\"' /=) <* char '\"' - noSpaceName = takeWhile1 (' ' /=) - --- | Assuming little-endian -ipv4Dotted :: Word32 -> HostName -ipv4Dotted addr = ipv4Format (bigToLittleEndian (hostAddressToTuple addr)) - where - bigToLittleEndian (a, b, c, d) = (d, c, b, a) - - ipv4Format (d,c,b,a) = - show d <> "." <> show c <> "." <> show b <> "." <> show a - -getFileOffset :: FilePath -> IO (Maybe Word32) -getFileOffset path = - do res <- E.try (withFile path ReadMode hFileSize) - return $! case res :: Either IOError Integer of - Right n | n > 0 -> Just $! fromIntegral n - _ -> Nothing - -insertAsNewMax :: DCCOffer -> DCCState -> DCCState -insertAsNewMax newoffer (DCCState offers transfers) = - let newmax = if I.null offers then 1 else 1 + fst (I.findMax offers) - newOffers = I.insert newmax newoffer offers - in DCCState newOffers transfers - -ctcpToTuple :: IrcMsg -> Maybe (UserInfo, Identifier, Text, Text) -ctcpToTuple (Ctcp fromU target command txt) = - Just (fromU, target, command, txt) -ctcpToTuple (CtcpNotice fromU target command txt) = - Just (fromU, target, command, txt) -ctcpToTuple _ = Nothing - --- | Check the status of a download at @Key@ by checking the invariants --- at @DCCState@ -statusAtKey :: Key -> DCCState -> ConnectionStatus -statusAtKey key (DCCState offers _) = - case I.lookup key offers of - Nothing -> NotExist - Just d -> view dccStatus d - --- | Craft a CTCP message indicating we want to resume a download at the offset. -resumeMsg :: - Word32 {- ^ offset -} -> - DCCOffer {- ^ offer -} -> - (String, String) {- ^ (target, txt) -} -resumeMsg sizeoffset offer = (target, txt) - where - filename = _dccFileName offer - port = show (_dccPort offer) - sizeoffset' = show sizeoffset - quoting = if ' ' `elem` filename then "\"" else "" - - txt = concat ["RESUME ", quoting, filename, quoting, - " ", port, " ", sizeoffset' ] - target = views (dccFromInfo . uiNick) (Text.unpack . idText) offer - --- | Modify the @DCCState@ following the corresponding @DCCUpdate@ -acceptUpdate :: DCCUpdate -> DCCState -> DCCState -acceptUpdate (Accept k port offset) state = - case view (dsOffers . at k) state of - Nothing -> state -- check at call-site - Just oldOffer -> set (dsOffers . at k) (Just newOffer) state - where - newOffer = oldOffer { _dccPort = port, _dccOffset = offset } -acceptUpdate _ state = state - --- | Check if the payload of a "DCC" CTCP message is SEND -isSend :: Text -> Bool -isSend txt - | "SEND":_ <- Text.splitOn " " txt = True - | otherwise = False 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 @@ -63,7 +63,6 @@ import Client.State.EditBox.Content import Control.Lens hiding (below) -import Data.Char import Data.List.NonEmpty (NonEmpty) @@ -226,16 +225,16 @@ -- | 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 saveKill e +killWordBackward :: (Char -> Bool) -> Bool {- ^ yank -} -> EditBox -> EditBox +killWordBackward p saveKill e = sometimesUpdateYank $ set line (Line (length l') (l'++r)) $ e where Line n txt = view line e (l,r) = splitAt n txt - (sp,l1) = span isSpace (reverse l) - (wd,l2) = break isSpace l1 + (sp,l1) = span p (reverse l) + (wd,l2) = break p l1 l' = reverse l2 yanked = reverse (sp++wd) @@ -245,16 +244,16 @@ -- | 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 saveKill e +killWordForward :: (Char -> Bool) -> Bool {- ^ yank -} -> EditBox -> EditBox +killWordForward p saveKill e = sometimesUpdateYank $ set line (Line (length l) (l++r2)) $ e where Line n txt = view line e (l,r) = splitAt n txt - (sp,r1) = span isSpace r - (wd,r2) = break isSpace r1 + (sp,r1) = span p r + (wd,r2) = break p r1 yanked = sp++wd sometimesUpdateYank diff --git a/src/Client/State/Extensions.hs b/src/Client/State/Extensions.hs --- a/src/Client/State/Extensions.hs +++ b/src/Client/State/Extensions.hs @@ -17,6 +17,7 @@ , clientNotifyExtensions , clientStopExtensions , clientExtTimer + , clientThreadJoin ) where import Control.Concurrent.MVar @@ -84,11 +85,14 @@ ClientState {- ^ client state -} -> IO ClientState {- ^ client state with extensions unloaded -} clientStopExtensions st = - do let (aes,st1) = st & clientExtensions . esActive <<.~ IntMap.empty + do let (aes,st1) = st & clientExtensions . esActive %%~ upd ifoldlM step st1 aes where + upd = fmap (fmap disable) . IntMap.partition readyToClose + disable ae = ae { aeLive = False } + readyToClose ae = aeThreads ae == 0 step i st2 ae = - do (st3,_) <- clientPark i st2 (deactivateExtension ae) + do (st3,_) <- clientPark i st2 (stopExtension ae) return st3 @@ -103,7 +107,7 @@ | noCallback = return (st, True) | otherwise = evalNestedIO $ do chat <- withChat net tgt msg - liftIO (chat1 chat st (IntMap.toList aes)) + liftIO (chat1 chat st (IntMap.toList (IntMap.filter aeLive aes))) where aes = view (clientExtensions . esActive) st noCallback = all (\ae -> fgnChat (aeFgn ae) == nullFunPtr) aes @@ -130,7 +134,7 @@ | noCallback = return (st, True) | otherwise = evalNestedIO $ do fgn <- withRawIrcMsg network raw - liftIO (message1 fgn st (IntMap.toList aes)) + liftIO (message1 fgn st (IntMap.toList (IntMap.filter aeLive aes))) where aes = view (clientExtensions . esActive) st noCallback = all (\ae -> fgnMessage (aeFgn ae) == nullFunPtr) aes @@ -156,7 +160,7 @@ IO (Maybe ClientState) {- ^ new client state on success -} clientCommandExtension name command st = case find (\(_,ae) -> aeName ae == name) - (IntMap.toList (view (clientExtensions . esActive) st)) of + (IntMap.toList (IntMap.filter aeLive (view (clientExtensions . esActive) st))) of Nothing -> return Nothing Just (i,ae) -> do (st', _) <- clientPark i st (commandExtension command ae) @@ -193,3 +197,25 @@ do let st1 = set (clientExtensions . esActive . ix i) ae' st (st2,_) <- clientPark i st1 (runTimerCallback fun dat timerId) return st2 + +-- | Run the thread join action on a given extension. +clientThreadJoin :: + Int {- ^ extension ID -} -> + ThreadEntry {- ^ thread result -} -> + ClientState {- ^ client state -} -> + IO ClientState +clientThreadJoin i thread st = + let ae = st ^?! clientExtensions . esActive . ix i + in finish ae { aeThreads = aeThreads ae - 1} + where + finish ae + | aeLive ae = -- normal behavior, run finalizer + do let st1 = set (clientExtensions . esActive . ix i) ae st + (st2,_) <- clientPark i st1 (threadFinish thread) + pure st2 + | aeThreads ae == 0 = -- delayed stop, all threads done + do let st1 = over (clientExtensions . esActive) (sans i) st + (st2,_) <- clientPark i st1 (stopExtension ae) + return st2 + | otherwise = -- delayed stop, more threads remain + do pure (set (clientExtensions . esActive . ix i) ae st) 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 @@ -48,6 +48,7 @@ , csMessageHooks , csAuthenticationState , csSeed + , csAway -- * Cross-message state , Transaction(..) @@ -131,6 +132,7 @@ , _csNetwork :: !Text -- ^ name of network connection , _csMessageHooks :: ![MessageHook] -- ^ names of message hooks to apply to this connection , _csAuthenticationState :: !AuthenticateState + , _csAway :: !Bool -- ^ Tracks when you are marked away -- Timing information , _csNextPingTime :: !(Maybe UTCTime) -- ^ time for next ping event @@ -276,6 +278,7 @@ , _csNetwork = network , _csMessageHooks = buildMessageHooks (view ssMessageHooks settings) , _csAuthenticationState = AS_None + , _csAway = False , _csPingStatus = ping , _csLatency = Nothing , _csNextPingTime = Nothing @@ -299,7 +302,7 @@ BatchEnd{} -> True Ping{} -> True Pong{} -> True - Reply RPL_WHOSPCRPL [_,"616",_,_,_,_] -> True + Reply _ RPL_WHOSPCRPL [_,"616",_,_,_,_] -> True _ -> False -- | Used for updates to a 'NetworkState' that require no reply. @@ -361,28 +364,28 @@ $ updateMyNick (userNick oldNick) newNick $ overChannels (nickChange (userNick oldNick) newNick) cs - Reply RPL_WELCOME (me:_) -> doWelcome msgWhen (mkId me) cs - Reply RPL_SASLSUCCESS _ -> reply [ircCapEnd] cs - Reply RPL_SASLFAIL _ -> reply [ircCapEnd] cs + Reply _ RPL_WELCOME (me:_) -> doWelcome msgWhen (mkId me) cs + Reply _ RPL_SASLSUCCESS _ -> reply [ircCapEnd] cs + Reply _ RPL_SASLFAIL _ -> reply [ircCapEnd] cs - Reply ERR_NICKNAMEINUSE (_:badnick:_) + Reply _ ERR_NICKNAMEINUSE (_:badnick:_) | PingConnecting{} <- view csPingStatus cs -> doBadNick badnick cs - Reply ERR_BANNEDNICK (_:badnick:_) + Reply _ ERR_BANNEDNICK (_:badnick:_) | PingConnecting{} <- view csPingStatus cs -> doBadNick badnick cs - Reply ERR_ERRONEUSNICKNAME (_:badnick:_) + Reply _ ERR_ERRONEUSNICKNAME (_:badnick:_) | PingConnecting{} <- view csPingStatus cs -> doBadNick badnick cs - Reply ERR_UNAVAILRESOURCE (_:badnick:_) + Reply _ ERR_UNAVAILRESOURCE (_:badnick:_) | PingConnecting{} <- view csPingStatus cs -> doBadNick badnick cs - Reply RPL_HOSTHIDDEN (_:host:_) -> + Reply _ RPL_HOSTHIDDEN (_:host:_) -> noReply (set (csUserInfo . uiHost) host cs) -- /who <#channel> %tuhna,616 - Reply RPL_WHOSPCRPL [_me,"616",user,host,nick,acct] -> + Reply _ RPL_WHOSPCRPL [_me,"616",user,host,nick,acct] -> let acct' = if acct == "0" then "*" else acct in noReply (recordUser (UserInfo (mkId nick) user host) acct' cs) - Reply code args -> doRpl code msgWhen args cs + Reply _ code args -> doRpl code msgWhen args cs Cap cmd -> doCap cmd cs Authenticate param -> doAuthenticate param cs Mode who target (modes:params) -> doMode msgWhen who target modes params cs @@ -438,7 +441,7 @@ primaryNick = NonEmpty.head (view (csSettings . ssNicks) cs) candidate = Text.take (limit-length suffix) primaryNick <> Text.pack suffix - (n, cs') = cs & csSeed %%~ Random.uniformR range + (n, cs') = cs & csSeed %%~ Random.randomR range doTopic :: ZonedTime -> UserInfo -> Identifier -> Text -> NetworkState -> NetworkState doTopic when user chan topic = @@ -591,6 +594,11 @@ where chanId = mkId chan !who = UserInfo "*" "" "" _ -> noReply cs + + -- Away flag tracking + RPL_NOWAWAY -> noReply (set csAway True cs) + RPL_UNAWAY -> noReply (set csAway False cs) + _ -> noReply cs @@ -661,8 +669,8 @@ -- so the user shouldn't need to see them directly to get the -- relevant information. squelchIrcMsg :: IrcMsg -> Bool -squelchIrcMsg (Reply rpl _) = squelchReply rpl -squelchIrcMsg _ = False +squelchIrcMsg (Reply _ rpl _) = squelchReply rpl +squelchIrcMsg _ = False doMode :: ZonedTime {- ^ time of message -} -> @@ -1050,7 +1058,9 @@ where action = case view csPingStatus cs of - PingSent{} -> TimedDisconnect + PingSent sentAt + | Just sentAt < view csLastReceived cs -> TimedSendPing + | otherwise -> TimedDisconnect PingNone -> TimedSendPing PingConnecting{} -> 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 @@ -15,12 +15,15 @@ ( -- * Windows Window(..) + , winName , winMessages , winUnread , winTotal , winMention , winMarker , winHideMeta + , winHidden + , winSilent -- * Window lines , WindowLines(..) @@ -42,6 +45,7 @@ , windowSeen , windowActivate , windowDeactivate + , windowClear -- * Packed time , PackedTime @@ -82,12 +86,15 @@ -- | A 'Window' tracks all of the messages and metadata for a particular -- message buffer. data Window = Window - { _winMessages :: !WindowLines -- ^ Messages to display, newest first + { _winName' :: !Char -- ^ Shortcut name (or NUL) + , _winMessages :: !WindowLines -- ^ Messages to display, newest first , _winMarker :: !(Maybe Int) -- ^ Location of line drawn to indicate newer messages , _winUnread :: !Int -- ^ Messages added since buffer was visible , _winTotal :: !Int -- ^ Messages in buffer , _winMention :: !WindowLineImportance -- ^ Indicates an important event is unread , _winHideMeta :: !Bool -- ^ Hide metadata messages + , _winHidden :: !Bool -- ^ Remove from jump rotation + , _winSilent :: !Bool -- ^ Ignore activity } data ActivityLevel = NoActivity | NormalActivity | HighActivity @@ -103,6 +110,8 @@ makeLenses ''Window makeLenses ''WindowLine +winName :: Lens' Window (Maybe Char) +winName = winName' . from (non '\0') wlText :: Getter WindowLine Text wlText = wlFullImage . to imageText @@ -110,18 +119,30 @@ -- | A window with no messages emptyWindow :: Window emptyWindow = Window - { _winMessages = Nil + { _winName' = '\0' + , _winMessages = Nil , _winMarker = Nothing , _winUnread = 0 , _winTotal = 0 , _winMention = WLBoring , _winHideMeta = False + , _winHidden = False + , _winSilent = False } +windowClear :: Window -> Window +windowClear w = w + { _winMessages = Nil + , _winMarker = Nothing + , _winUnread = 0 + , _winTotal = 0 + , _winMention = WLBoring + } + -- | Adds a given line to a window as the newest message. Window's -- unread count will be updated according to the given importance. addToWindow :: WindowLine -> Window -> Window -addToWindow !msg !win = Window +addToWindow !msg !win = win { _winMessages = msg :- view winMessages win , _winTotal = view winTotal win + 1 , _winMarker = (+1) <$!> view winMarker win diff --git a/src/Client/View.hs b/src/Client/View.hs --- a/src/Client/View.hs +++ b/src/Client/View.hs @@ -19,7 +19,6 @@ import Client.View.Cert import Client.View.ChannelInfo import Client.View.Digraphs -import Client.View.DCCList import Client.View.Help import Client.View.IgnoreList import Client.View.KeyMap @@ -42,11 +41,10 @@ channelInfoImages network channel st (ChannelFocus network channel, FocusUsers) | view clientDetailView st -> userInfoImages network channel st - | otherwise -> userListImages network channel st + | otherwise -> userListImages network channel w st (ChannelFocus network channel, FocusMasks mode) -> maskListImages mode network channel w st (_, FocusWindows filt) -> windowsImages filt st - (_, FocusDCC) -> dccImages st (_, FocusMentions) -> mentionsViewLines w st (_, FocusPalette) -> paletteViewLines pal (_, FocusDigraphs) -> digraphLines w st diff --git a/src/Client/View/Cert.hs b/src/Client/View/Cert.hs --- a/src/Client/View/Cert.hs +++ b/src/Client/View/Cert.hs @@ -20,6 +20,7 @@ import Client.State.Network import Control.Lens import Data.Text (Text) +import qualified Data.Text.Lazy as LText -- | Render the lines used in a channel mask list certViewLines :: @@ -29,7 +30,8 @@ , Just cs <- preview (clientConnection network) st , let xs = view csCertificate cs , not (null xs) - = parseIrcText <$> xs + = map parseIrcText + $ clientFilter st LText.fromStrict xs | otherwise = [text' (view palError pal) "No certificate available"] where diff --git a/src/Client/View/ChannelInfo.hs b/src/Client/View/ChannelInfo.hs --- a/src/Client/View/ChannelInfo.hs +++ b/src/Client/View/ChannelInfo.hs @@ -22,13 +22,14 @@ import Client.Image.Palette import Client.State import Client.State.Channel +import Client.State.Focus import Client.State.Network import Control.Lens -import Data.HashSet (HashSet) import Data.Text (Text) import Data.Time import Graphics.Vty.Attributes import Irc.Identifier +import Data.HashMap.Strict (HashMap) import qualified Data.Map as Map import qualified Data.Text as Text @@ -41,13 +42,13 @@ | Just cs <- preview (clientConnection network) st , Just channel <- preview (csChannels . ix channelId) cs - = channelInfoImages' pal (clientHighlights cs st) channel + = channelInfoImages' pal (clientHighlightsFocus (NetworkFocus network) st) channel | otherwise = [text' (view palError pal) "No channel information"] where pal = clientPalette st -channelInfoImages' :: Palette -> HashSet Identifier -> ChannelState -> [Image'] +channelInfoImages' :: Palette -> HashMap Identifier Highlight -> ChannelState -> [Image'] channelInfoImages' pal myNicks !channel = reverse $ topicLine diff --git a/src/Client/View/DCCList.hs b/src/Client/View/DCCList.hs deleted file mode 100644 --- a/src/Client/View/DCCList.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# language LambdaCase #-} -{-| -Module : Client.View.DCCList -Description : View of the DCC offers and transfers -Copyright : (c) Ruben Astudillo, 2019 -License : ISC -Maintainer : ruben.astud@gmail.com - -This module implements the rendering of the client DCC offer list. - --} -module Client.View.DCCList - ( dccImages - ) where - -import Client.Image.PackedImage -import Client.Image.Palette -import Client.State -import Control.Lens -import Data.List -import qualified Data.IntMap as IntMap -import Graphics.Vty.Attributes -import Client.State.DCC - - --- TODO: maybe express more clearly? -dccImages :: ClientState -> [Image'] -dccImages st = - let dccState = view clientDCC st - (keys, offers) = views dsOffers (unzip . IntMap.toAscList) dccState - pal = clientPalette st - - imgKeys = map (string (_palLabel pal) . show) keys - imgNames = map (string defAttr . _dccFileName) offers - statusOff key = showStatus (statusAtKey key dccState) - downloading = map (string (_palMeta pal) . statusOff) keys - percentage = map (\k -> string (_palTextBox pal) - $ maybe " " (\p -> show p ++ "%") - $ preview (dsTransfers . ix k . dtProgress) dccState) - keys - - downloadingNum = - length (filter (\key -> Downloading == statusAtKey key dccState) keys) - - countImage = string (view palLabel pal) "Offers (downloading/total): " <> - string defAttr (show downloadingNum) <> - char (view palLabel pal) '/' <> - string defAttr (show (length keys)) - in countImage : - (reverse . createColumns - $ transpose [imgKeys, imgNames, downloading, percentage]) - -createColumns :: [[Image']] -> [Image'] -createColumns xs = map makeRow xs - where - columnWidths = maximum . map imageWidth <$> transpose xs - makeRow = mconcat - . intersperse (char defAttr ' ') - . zipWith resizeImage columnWidths - -showStatus :: ConnectionStatus -> String -showStatus = \case - CorrectlyFinished -> "Finished" - UserKilled -> "Killed by user" - LostConnection -> "Socket failure" - Downloading -> "Downloading" - Pending -> "Pending" - NotExist -> "Missing" -- logic error diff --git a/src/Client/View/Mentions.hs b/src/Client/View/Mentions.hs --- a/src/Client/View/Mentions.hs +++ b/src/Client/View/Mentions.hs @@ -34,8 +34,6 @@ mentionsViewLines w st = addMarkers w st entries where - names = clientWindowNames st ++ repeat '?' - detail = view clientDetailView st padAmt = view (clientConfig . configNickPadding) st @@ -46,14 +44,12 @@ | otherwise = filter (\x -> WLImportant == view wlImportance x) entries = merge - [windowEntries filt palette w padAmt detail n focus v - | (n,(focus, v)) - <- names `zip` Map.toList (view clientWindows st) ] + [windowEntries filt palette w padAmt detail focus v + | (focus, v) <- Map.toList (view clientWindows st) ] data MentionLine = MentionLine { mlTimestamp :: UTCTime -- ^ message timestamp for sorting - , mlWindowName :: Char -- ^ window names shortcut , mlFocus :: Focus -- ^ associated window , mlImage :: [Image'] -- ^ wrapped rendered lines } @@ -81,14 +77,12 @@ Int {- ^ draw columns -} -> PaddingMode {- ^ nick padding -} -> Bool {- ^ detailed view -} -> - Char {- ^ window name -} -> Focus {- ^ window focus -} -> Window {- ^ window -} -> [MentionLine] -windowEntries filt palette w padAmt detailed name focus win = +windowEntries filt palette w padAmt detailed focus win = [ MentionLine { mlTimestamp = views wlTimestamp unpackUTCTime l - , mlWindowName = name , mlFocus = focus , mlImage = case metadataImg (view wlSummary l) of _ | detailed -> [view wlFullImage l] diff --git a/src/Client/View/Messages.hs b/src/Client/View/Messages.hs --- a/src/Client/View/Messages.hs +++ b/src/Client/View/Messages.hs @@ -66,7 +66,7 @@ isNoisy msg = case view wlSummary msg of - ReplySummary code -> squelchIrcMsg (Reply code []) + ReplySummary code -> squelchIrcMsg (Reply "" code []) _ -> False detailedImagesWithoutMetadata :: ClientState -> [WindowLine] -> [Image'] diff --git a/src/Client/View/Palette.hs b/src/Client/View/Palette.hs --- a/src/Client/View/Palette.hs +++ b/src/Client/View/Palette.hs @@ -28,6 +28,9 @@ columns :: [Image'] -> Image' columns = mconcat . intersperse (char defAttr ' ') +indent :: Image' -> Image' +indent x = " " <> x + -- | Generate lines used for @/palette@. These lines show -- all the colors used in the current palette as well as -- the colors available for use in palettes. @@ -38,25 +41,20 @@ , "" , columns (paletteEntries pal) , "" - , "Current client palette nick highlight colors:" , "" - , columns (nickHighlights pal) - , "" - + ] ++ + nickHighlights pal ++ + [ "" , "Chat formatting modes:" , "" - , " C-b C-_ C-] C-v C-o" - , parseIrcText " \^Bbold\^B \^_underline\^_ \^]italic\^] \^Vreverse\^V reset" + , " C-b C-_ C-] C-v C-^ C-o" + , parseIrcText " \^Bbold\^B \^_underline\^_ \^]italic\^] \^Vreverse\^V \^^strikethrough\^^ reset" , "" - , "Chat formatting colors: C-c[foreground[,background]]" , "" ] ++ - - colorTable - - ++ + colorTable ++ [ "" , "Available terminal palette colors (hex)" , "" @@ -68,14 +66,13 @@ isoColors : "" : colorBox 0x10 ++ "" : colorBox 0x7c ++ - "" : " " <> foldMap (\c -> colorBlock showPadHex c (Color240 (fromIntegral (c-16)))) [0xe8 .. 0xf3] - : " " <> foldMap (\c -> colorBlock showPadHex c (Color240 (fromIntegral (c-16)))) [0xf4 .. 0xff] + "" : indent (foldMap (\c -> colorBlock showPadHex c (Color240 (fromIntegral (c-16)))) [0xe8 .. 0xf3]) + : indent (foldMap (\c -> colorBlock showPadHex c (Color240 (fromIntegral (c-16)))) [0xf4 .. 0xff]) : [] colorBox :: Int -> [Image'] colorBox start = - [ " " <> - columns + [ indent $ columns [ mconcat [ colorBlock showPadHex k (Color240 (fromIntegral (k - 16))) | k <- [j, j+6 .. j + 30 ] ] @@ -93,11 +90,11 @@ isoColors :: Image' -isoColors = " " <> foldMap (\c -> colorBlock showPadHex c (ISOColor (fromIntegral c))) [0 .. 15] +isoColors = indent (foldMap (\c -> colorBlock showPadHex c (ISOColor (fromIntegral c))) [0 .. 15]) colorTable :: [Image'] colorTable - = map (\imgs -> mconcat (" " : imgs)) + = map (indent . mconcat) $ chunksOf 8 [ colorBlock showPadDec i (mircColors Vector.! i) | i <- [0 .. 15] ] ++ [[]] ++ chunksOf 12 [ colorBlock showPadDec i (mircColors Vector.! i) | i <- [16 .. 98] ] @@ -124,6 +121,8 @@ nickHighlights :: Palette -> [Image'] nickHighlights pal = - [ string attr "nicks" - | attr <- toListOf (palNicks . folded) pal + [ indent (columns line) + | line <- chunksOf 8 + [ string attr "nicks" + | attr <- views palNicks Vector.toList pal ] ] diff --git a/src/Client/View/UrlSelection.hs b/src/Client/View/UrlSelection.hs --- a/src/Client/View/UrlSelection.hs +++ b/src/Client/View/UrlSelection.hs @@ -22,11 +22,9 @@ import Client.Message import Client.State import Client.State.Focus -import Client.State.Network import Client.State.Window import Control.Lens -import Data.HashSet (HashSet) -import qualified Data.HashSet as HashSet +import Data.HashMap.Strict (HashMap) import Data.Text (Text) import Graphics.Vty.Attributes import Irc.Identifier @@ -43,7 +41,7 @@ [Image'] {- ^ image lines -} urlSelectionView w focus arg st = concat - $ zipWith (draw w me pal padding selected) [1..] (toListOf urled st) + $ zipWith (draw w hilites pal padding selected) [1..] (toListOf urled st) where urled = clientWindows . ix focus . winMessages . each @@ -61,9 +59,7 @@ padding = view configNickPadding cfg pal = view configPalette cfg - me = maybe HashSet.empty HashSet.singleton - $ do net <- focusNetwork focus - preview (clientConnection net . csNick) st + hilites = clientHighlightsFocus focus st matches :: WindowLine -> [(Maybe Identifier, Text)] @@ -88,19 +84,19 @@ -- | Render one line of the url list draw :: Int {- ^ rendered width -} -> - HashSet Identifier {- ^ my nick -} -> + HashMap Identifier Highlight {- ^ highlights -} -> Palette {- ^ palette -} -> PaddingMode {- ^ nick render padding -} -> Int {- ^ selected index -} -> Int {- ^ url index -} -> (Maybe Identifier, Text) {- ^ sender and url text -} -> [Image'] {- ^ rendered lines -} -draw w me pal padding selected i (who,url) +draw w hilites pal padding selected i (who,url) = reverse $ lineWrapPrefix w (string defAttr (shows i ". ") <> nickPad padding - (foldMap (coloredIdentifier pal NormalIdentifier me) who) <> ": ") + (foldMap (coloredIdentifier pal NormalIdentifier hilites) who) <> ": ") (text' attr (cleanText url)) where attr | selected == i = withStyle defAttr reverseVideo diff --git a/src/Client/View/UserList.hs b/src/Client/View/UserList.hs --- a/src/Client/View/UserList.hs +++ b/src/Client/View/UserList.hs @@ -18,12 +18,14 @@ import Client.Image.Palette import Client.State import Client.State.Channel +import Client.State.Focus import Client.State.Network import Client.UserHost import Control.Lens import qualified Data.HashMap.Strict as HashMap import qualified Data.Map.Strict as Map import Data.List +import Data.List.Split import Data.Ord import Data.Text (Text) import qualified Data.Text as Text @@ -36,28 +38,34 @@ -- These lines show the count of users having each channel mode -- in addition to the nicknames of the users. userListImages :: - Text {- ^ network -} -> - Identifier {- ^ channel -} -> - ClientState -> + Text {- ^ network -} -> + Identifier {- ^ channel -} -> + Int {- ^ window width -} -> + ClientState {- ^ client state -} -> [Image'] -userListImages network channel st = +userListImages network channel w st = case preview (clientConnection network) st of - Just cs -> userListImages' cs channel st + Just cs -> userListImages' cs channel w st Nothing -> [text' (view palError pal) "No connection"] where pal = clientPalette st -userListImages' :: NetworkState -> Identifier -> ClientState -> [Image'] -userListImages' cs channel st = - [countImage, mconcat (intersperse gap (map renderUser usersList))] +userListImages' :: NetworkState -> Identifier -> Int -> ClientState -> [Image'] +userListImages' cs channel w st + = countImage : reverse [mconcat (intersperse gap row) | row <- chunksOf columns paddedNames] where + paddedNames = map (resizeImage maxWidth) nameImages + nameImages = map renderUser usersList + maxWidth = maximum (map imageWidth nameImages) + columns = max 1 ((w+1) `quot` (maxWidth+1)) + countImage = drawSigilCount pal (map snd usersList) - myNicks = clientHighlights cs st + hilites = clientHighlightsFocus (ChannelFocus (view csNetwork cs) channel) st renderUser (ident, sigils) = string (view palSigil pal) sigils <> - coloredIdentifier pal NormalIdentifier myNicks ident + coloredIdentifier pal NormalIdentifier hilites ident gap = char defAttr ' ' @@ -106,13 +114,13 @@ where countImage = drawSigilCount pal (map snd usersList) - myNicks = clientHighlights cs st + hilites = clientHighlightsFocus (ChannelFocus (view csNetwork cs) channel) st pal = clientPalette st renderEntry ((info, acct), sigils) = string (view palSigil pal) sigils <> - coloredUserInfo pal DetailedRender myNicks info <> + coloredUserInfo pal DetailedRender hilites info <> " " <> text' (view palMeta pal) (cleanText acct) filterOn ((info, acct),sigils) = diff --git a/src/Client/View/Windows.hs b/src/Client/View/Windows.hs --- a/src/Client/View/Windows.hs +++ b/src/Client/View/Windows.hs @@ -1,3 +1,4 @@ +{-# Language OverloadedStrings #-} {-| Module : Client.View.Windows Description : View of the list of open windows @@ -20,23 +21,27 @@ import Client.State.Network import Control.Lens import Data.List +import Data.Maybe (fromMaybe) import qualified Data.Map as Map import Graphics.Vty.Attributes import Irc.Identifier -- | Draw the image lines associated with the @/windows@ command. windowsImages :: WindowsFilter -> ClientState -> [Image'] -windowsImages filt st = reverse (createColumns windows) +windowsImages filt st + = reverse + $ createColumns + $ [ renderWindowColumns pal (char (view palError pal) 'h') k v | (k,v) <- hiddenWindows ] ++ + [ renderWindowColumns pal (char (view palWindowName pal) (name v)) k v | (k,v) <- windows ] where - windows = [ renderWindowColumns pal n k v - | (n,(k,v)) <- zip names - $ views clientWindows Map.toAscList st - , windowMatcher filt st k - ] - - pal = clientPalette st - names = clientWindowNames st ++ repeat '?' + pal = clientPalette st + name = fromMaybe ' ' . view winName + (hiddenWindows, windows) + = partition (view (_2 . winHidden)) + $ filter (windowMatcher filt st . fst) + $ Map.toAscList + $ view clientWindows st ------------------------------------------------------------------------ @@ -61,9 +66,9 @@ ------------------------------------------------------------------------ -renderWindowColumns :: Palette -> Char -> Focus -> Window -> [Image'] +renderWindowColumns :: Palette -> Image' -> Focus -> Window -> [Image'] renderWindowColumns pal name focus win = - [ char (view palWindowName pal) name + [ name , renderedFocus pal focus , renderedWindowInfo pal win ] @@ -91,9 +96,9 @@ 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) + string (view newMsgAttrLens pal) (views winUnread show win) <> "/" <> + string (view palActivity pal) (views winTotal show win) <> + (if view winSilent win then text' (view palMeta pal) " silent" else mempty) where newMsgAttrLens = case view winMention win of