glirc 2.37 → 2.38
raw patch · 55 files changed
+1462/−1103 lines, 55 filesdep −semigroupoidsdep ~basedep ~config-schemadep ~hookup
Dependencies removed: semigroupoids
Dependency ranges changed: base, config-schema, hookup, irc-core, lens, random, template-haskell, time, unordered-containers, vty
Files
- ChangeLog.md +16/−0
- README.md +21/−7
- exec/Exports.hs +2/−0
- exec/linux_exported_symbols.txt +2/−0
- exec/macos_exported_symbols.txt +2/−0
- glirc.cabal +10/−14
- include/glirc-api.h +2/−0
- src/Client/CApi.hs +16/−6
- src/Client/CApi/Exports.hs +70/−3
- src/Client/CApi/Types.hsc +17/−0
- src/Client/Commands.hs +10/−8
- src/Client/Commands/Channel.hs +7/−1
- src/Client/Commands/Chat.hs +32/−1
- src/Client/Commands/Connection.hs +12/−1
- src/Client/Commands/DCC.hs +0/−111
- src/Client/Commands/Interpolation.hs +2/−1
- src/Client/Commands/Operator.hs +24/−1
- src/Client/Commands/TabCompletion.hs +19/−3
- src/Client/Commands/Toggles.hs +11/−0
- src/Client/Commands/Window.hs +81/−14
- src/Client/Commands/WordCompletion.hs +25/−11
- src/Client/Commands/ZNC.hs +1/−1
- src/Client/Configuration.hs +59/−41
- src/Client/Configuration/Colors.hs +2/−1
- src/Client/Configuration/ServerSettings.hs +23/−7
- src/Client/EventLoop.hs +21/−35
- src/Client/EventLoop/Actions.hs +9/−2
- src/Client/EventLoop/Errors.hs +1/−1
- src/Client/EventLoop/Network.hs +2/−2
- src/Client/Hook/Snotice.hs +7/−0
- src/Client/Image.hs +5/−6
- src/Client/Image/Layout.hs +10/−10
- src/Client/Image/Message.hs +470/−99
- src/Client/Image/MircFormatting.hs +31/−13
- src/Client/Image/Palette.hs +8/−0
- src/Client/Image/StatusLine.hs +61/−50
- src/Client/Image/Textbox.hs +83/−26
- src/Client/Log.hs +8/−4
- src/Client/Message.hs +1/−3
- src/Client/State.hs +116/−92
- src/Client/State/DCC.hs +0/−356
- src/Client/State/EditBox.hs +8/−9
- src/Client/State/Extensions.hs +31/−5
- src/Client/State/Network.hs +25/−15
- src/Client/State/Window.hs +24/−3
- src/Client/View.hs +1/−3
- src/Client/View/Cert.hs +3/−1
- src/Client/View/ChannelInfo.hs +4/−3
- src/Client/View/DCCList.hs +0/−68
- src/Client/View/Mentions.hs +3/−9
- src/Client/View/Messages.hs +1/−1
- src/Client/View/Palette.hs +18/−19
- src/Client/View/UrlSelection.hs +6/−10
- src/Client/View/UserList.hs +20/−12
- src/Client/View/Windows.hs +19/−14
ChangeLog.md view
@@ -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
README.md view
@@ -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 -------
exec/Exports.hs view
@@ -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
exec/linux_exported_symbols.txt view
@@ -22,4 +22,6 @@ glirc_free_strings; glirc_set_timer; glirc_cancel_timer;+glirc_window_lines;+glirc_thread; };
exec/macos_exported_symbols.txt view
@@ -21,3 +21,5 @@ _glirc_free_strings _glirc_set_timer _glirc_cancel_timer+_glirc_window_lines+_glirc_thread
glirc.cabal view
@@ -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
include/glirc-api.h view
@@ -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 **);
src/Client/CApi.hs view
@@ -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.
src/Client/CApi/Exports.hs view
@@ -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)
src/Client/CApi/Types.hsc view
@@ -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 ------------------------------------------------------------------------
src/Client/Commands.hs view
@@ -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
src/Client/Commands/Channel.hs view
@@ -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
src/Client/Commands/Chat.hs view
@@ -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)
src/Client/Commands/Connection.hs view
@@ -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 =
− src/Client/Commands/DCC.hs
@@ -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)
src/Client/Commands/Interpolation.hs view
@@ -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
src/Client/Commands/Operator.hs view
@@ -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))
src/Client/Commands/TabCompletion.hs view
@@ -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 ->
src/Client/Commands/Toggles.hs view
@@ -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
src/Client/Commands/Window.hs view
@@ -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
src/Client/Commands/WordCompletion.hs view
@@ -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.
src/Client/Commands/ZNC.hs view
@@ -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
src/Client/Configuration.hs view
@@ -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 }
src/Client/Configuration/Colors.hs view
@@ -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"
src/Client/Configuration/ServerSettings.hs view
@@ -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
src/Client/EventLoop.hs view
@@ -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
src/Client/EventLoop/Actions.hs view
@@ -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") ]) :
src/Client/EventLoop/Errors.hs view
@@ -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" :| []
src/Client/EventLoop/Network.hs view
@@ -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
src/Client/Hook/Snotice.hs view
@@ -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 |]),
src/Client/Image.hs view
@@ -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
src/Client/Image/Layout.hs view
@@ -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@
src/Client/Image/Message.hs view
@@ -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 == "<NULL>" 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
src/Client/Image/MircFormatting.hs view
@@ -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
src/Client/Image/Palette.hs view
@@ -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) ]
src/Client/Image/StatusLine.hs view
@@ -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 =
src/Client/Image/Textbox.hs view
@@ -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)
src/Client/Log.hs view
@@ -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
src/Client/Message.hs view
@@ -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
src/Client/State.hs view
@@ -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 ::
− src/Client/State/DCC.hs
@@ -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
src/Client/State/EditBox.hs view
@@ -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
src/Client/State/Extensions.hs view
@@ -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)
src/Client/State/Network.hs view
@@ -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
src/Client/State/Window.hs view
@@ -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
src/Client/View.hs view
@@ -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
src/Client/View/Cert.hs view
@@ -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
src/Client/View/ChannelInfo.hs view
@@ -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
− src/Client/View/DCCList.hs
@@ -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
src/Client/View/Mentions.hs view
@@ -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]
src/Client/View/Messages.hs view
@@ -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']
src/Client/View/Palette.hs view
@@ -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 ] ]
src/Client/View/UrlSelection.hs view
@@ -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
src/Client/View/UserList.hs view
@@ -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) =
src/Client/View/Windows.hs view
@@ -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