glirc 2.30 → 2.31

raw patch · 35 files changed

+1755/−482 lines, 35 filesdep +regex-tdfa-textdep ~asyncdep ~hashabledep ~hookupPVP ok

version bump matches the API change (PVP)

Dependencies added: regex-tdfa-text

Dependency ranges changed: async, hashable, hookup, irc-core, network

API changes (from Hackage documentation)

Files

• ChangeLog.md +13/−0
• README.md +3/−0
• glirc.cabal +13/−7
• include/glirc-api.h +6/−6
• src/Client/CApi.hs +13/−15
• src/Client/CApi/Exports.hs +14/−9
• src/Client/CApi/Types.hsc +0/−6
• src/Client/Commands.hs +139/−37
• src/Client/Commands/Arguments/Spec.hs +4/−0
• src/Client/Commands/Exec.hs +8/−7
• src/Client/Configuration.hs +52/−4
• src/Client/Configuration/ServerSettings.hs +53/−0
• src/Client/EventLoop.hs +82/−178
• src/Client/EventLoop/Network.hs +162/−0
• src/Client/Hook/FreRelay.hs +182/−0
• src/Client/Hook/Snotice.hs +150/−4
• src/Client/Hooks.hs +2/−0
• src/Client/Image/Message.hs +86/−29
• src/Client/Image/Palette.hs +11/−0
• src/Client/Image/StatusLine.hs +33/−19
• src/Client/Image/Textbox.hs +9/−20
• src/Client/Message.hs +3/−0
• src/Client/Network/Async.hs +93/−38
• src/Client/State.hs +57/−44
• src/Client/State/DCC.hs +357/−0
• src/Client/State/Extensions.hs +11/−11
• src/Client/State/Focus.hs +3/−1
• src/Client/State/Network.hs +17/−7
• src/Client/View.hs +11/−7
• src/Client/View/Cert.hs +43/−0
• src/Client/View/ChannelInfo.hs +15/−1
• src/Client/View/DCCList.hs +68/−0
• src/Client/View/Messages.hs +1/−0
• src/Client/View/Palette.hs +40/−32
• src/Client/View/UrlSelection.hs +1/−0

@@ -1,5 +1,18 @@ # Revision history for glirc2 +## 2.31++* Added TLS fingerprint pinning with `tls-cert-fingerprint` and `tls-pubkey-fingerprint`+* Addded `/cert` command+* Improved C API `void*` passing to always pass around a single pointer.+* Better rendering for `/whois` and `/whowas`+* Better support for ircop commands, responses, and modes+* Channel, user, and snomask modes are can be styled+* Bugfix in textbox rendering for formatted multi-line inputs.+* Improved `/palette` rendering+* Switch window focus when *forwarded*+* Add support for receiving files with DCC (thanks Ruben Astudillo)+ ## 2.30  * Implement support for chghost <https://ircv3.net/specs/extensions/chghost-3.2.html>

@@ -143,6 +143,7 @@    width: 13  url-opener: "open" -- This works on macOS, "gnome-open" for GNOME+download-dir: "~/Downloads" -- defaults to HOME  key-bindings:   * bind: "C-M-b"@@ -179,6 +180,7 @@ | `extra-highlights`     | list of text        | Extra words/nicks to highlight                                                             | | `extensions`           | list of text        | Filenames of extension to load                                                             | | `url-opener`           | text                | Command to execute with URL parameter for `/url` e.g. gnome-open on GNOME or open on macOS |+| `download-dir`         | text                | path to the directory where to place DCC downloads, defaults to HOME                       | | `ignores`              | list of text        | Initial list of nicknames to ignore                                                        | | `activity-bar`         | yes or no           | Initial setting for visibility of activity bar (default no)                                | | `bell-on-mention`      | yes or no           | Sound terminal bell on transition from not mentioned to mentioned (default no)             |@@ -282,6 +284,7 @@ * `/extension <extension name> <params...>` - Send the given params to the named extension * `/exec [-n network] [-c channel] <command> <arguments...>` - Execute a command, If no network or channel are provided send output to client window, if network and channel are provided send output as messages, if network is provided send output as raw IRC messages. * `/url [n]` - Execute url-opener on the nth URL in the current window (defaults to first)+* `/dcc [(accept|resume|cancel|clear)] [n]` - Execute the corresponding action on the nth offer.  View toggles * `/toggle-detail` - toggle full detail view of messages

@@ -1,6 +1,6 @@ cabal-version:       2.2 name:                glirc-version:             2.30+version:             2.31 synopsis:            Console IRC client description:         Console IRC client                      .@@ -19,7 +19,7 @@                      exec/macos_exported_symbols.txt homepage:            https://github.com/glguy/irc-core bug-reports:         https://github.com/glguy/irc-core/issues-tested-with:         GHC==8.6.3+tested-with:         GHC==8.6.4  custom-setup   setup-depends: base     >=4.11 && <4.13,@@ -76,7 +76,9 @@                        Client.EventLoop                        Client.EventLoop.Actions                        Client.EventLoop.Errors+                       Client.EventLoop.Network                        Client.Hook+                       Client.Hook.FreRelay                        Client.Hook.Snotice                        Client.Hook.Znc.Buffextras                        Client.Hooks@@ -97,6 +99,7 @@                        Client.Options                        Client.State                        Client.State.Channel+                       Client.State.DCC                        Client.State.EditBox                        Client.State.EditBox.Content                        Client.State.Extensions@@ -104,8 +107,10 @@                        Client.State.Network                        Client.State.Window                        Client.View+                       Client.View.Cert                        Client.View.ChannelInfo                        Client.View.Digraphs+                       Client.View.DCCList                        Client.View.Help                        Client.View.IgnoreList                        Client.View.KeyMap@@ -133,7 +138,7 @@    build-depends:       base                 >=4.11   && <4.13,                        HsOpenSSL            >=0.11   && <0.12,-                       async                >=2.1    && <2.3,+                       async                >=2.2    && <2.3,                        attoparsec           >=0.13   && <0.14,                        base64-bytestring    >=1.0.0.1&& <1.1,                        bytestring           >=0.10.8 && <0.11,@@ -144,15 +149,16 @@                        filepath             >=1.4.1  && <1.5,                        free                 >=4.12   && <5.2,                        gitrev               >=1.2    && <1.4,-                       hashable             >=1.2.4  && <1.3,-                       hookup               >=0.2.2  && <0.3,-                       irc-core             >=2.6    && <2.7,+                       hashable             >=1.2.4  && <1.4,+                       hookup               >=0.2.3  && <0.3,+                       irc-core             >=2.7    && <2.8,                        kan-extensions       >=5.0    && <5.3,                        lens                 >=4.14   && <4.18,-                       network              >=2.6.2  && <3.1,+                       network              >=2.6.2  && <3.2,                        process              >=1.4.2  && <1.7,                        psqueues             >=0.2.7  && <0.3,                        regex-tdfa           >=1.2    && <1.3,+                       regex-tdfa-text      >=1.0    && <1.1,                        semigroupoids        >=5.1    && <5.4,                        split                >=0.2    && <0.3,                        stm                  >=2.4    && <2.6,

@@ -44,13 +44,13 @@ };  typedef void *start_type         (struct glirc *G, const char *path, const struct glirc_string *args, size_t args_len);-typedef void stop_type           (struct glirc *G, void *S);-typedef enum process_result process_message_type(struct glirc *G, void *S, const struct glirc_message *);-typedef enum process_result process_chat_type(struct glirc *G, void *S, const struct glirc_chat *);-typedef void process_command_type(struct glirc *G, void *S, const struct glirc_command *);+typedef void stop_type           (void *S);+typedef enum process_result process_message_type(void *S, const struct glirc_message *);+typedef enum process_result process_chat_type(void *S, const struct glirc_chat *);+typedef void process_command_type(void *S, const struct glirc_command *);  typedef long timer_id;-typedef void timer_callback(struct glirc *G, void *S, void *dat, timer_id);+typedef void timer_callback(void *dat, timer_id);  struct glirc_extension {         const char *name;@@ -88,7 +88,7 @@                                         const char *tgt, size_t tgtlen); 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);+void *glirc_cancel_timer(struct glirc *G, timer_id tid);  void glirc_free_string(char *); void glirc_free_strings(char **);

@@ -112,9 +112,10 @@ cancelTimer ::   Int             {- ^ timer ID  -}  ->   ActiveExtension {- ^ extension -}  ->-  ActiveExtension-cancelTimer timerId ae = ae-  { aeTimers = IntPSQ.delete timerId (aeTimers ae) }+  Maybe (Ptr (), ActiveExtension)+cancelTimer timerId ae =+  do (_, TimerEntry _ ptr) <- IntPSQ.lookup timerId (aeTimers ae)+     return (ptr, ae { aeTimers = IntPSQ.delete timerId (aeTimers ae)})  -- | Load the extension from the given path and call the start -- callback. The result of the start callback is saved to be@@ -158,11 +159,11 @@  -- | Call the stop callback of the extension if it is defined -- and unload the shared object.-deactivateExtension :: Ptr () -> ActiveExtension -> IO ()-deactivateExtension stab ae =+deactivateExtension :: ActiveExtension -> IO ()+deactivateExtension ae =   do let f = fgnStop (aeFgn ae)      unless (nullFunPtr == f) $-       runStopExtension f stab (aeSession ae)+       runStopExtension f (aeSession ae)      dlclose (aeDL ae)  @@ -172,15 +173,14 @@ -- -- Returns 'True' to pass message to client.  Returns 'False to drop message. chatExtension ::-  Ptr ()          {- ^ client callback handle  -} ->   ActiveExtension {- ^ extension               -} ->   Ptr FgnChat     {- ^ serialized chat message -} ->   IO Bool         {- ^ allow message           -}-chatExtension stab ae chat =+chatExtension ae chat =   do let f = fgnChat (aeFgn ae)      if f == nullFunPtr        then return True-       else (passMessage ==) <$> runProcessChat f stab (aeSession ae) chat+       else (passMessage ==) <$> runProcessChat f (aeSession ae) chat  -- | Call all of the process message callbacks in the list of extensions. -- This operation marshals the IRC message once and shares that across@@ -188,28 +188,26 @@ -- -- Returns 'True' to pass message to client.  Returns 'False to drop message. notifyExtension ::-  Ptr ()          {- ^ clientstate stable pointer -} ->   ActiveExtension {- ^ extension                  -} ->   Ptr FgnMsg      {- ^ serialized IRC message     -} ->   IO Bool         {- ^ allow message              -}-notifyExtension stab ae msg =+notifyExtension ae msg =   do let f = fgnMessage (aeFgn ae)      if f == nullFunPtr        then return True-       else (passMessage ==) <$> runProcessMessage f stab (aeSession ae) msg+       else (passMessage ==) <$> runProcessMessage f (aeSession ae) msg   -- | Notify an extension of a client command with the given parameters. commandExtension ::-  Ptr ()          {- ^ client state stableptr -} ->   Text            {- ^ command                -} ->   ActiveExtension {- ^ extension to command   -} ->   IO ()-commandExtension stab command ae = evalNestedIO $+commandExtension command ae = evalNestedIO $   do cmd <- withCommand command      let f = fgnCommand (aeFgn ae)      liftIO $ unless (f == nullFunPtr)-            $ runProcessCommand f stab (aeSession ae) cmd+            $ runProcessCommand f (aeSession ae) cmd  -- | Marshal a 'RawIrcMsg' into a 'FgnMsg' which will be valid for -- the remainder of the computation.

@@ -99,7 +99,9 @@ import           Control.Monad (unless) import           Data.Char (chr) import           Data.Foldable (traverse_)+import           Data.Functor.Compose import qualified Data.Map as Map+import           Data.Monoid (First(..)) import qualified Data.HashMap.Strict as HashMap import           Data.Text (Text) import qualified Data.Text as Text@@ -261,7 +263,7 @@ glirc_list_networks stab =   do mvar <- derefToken stab      (_,st) <- readMVar mvar-     let networks = views clientNetworkMap HashMap.keys st+     let networks = views clientConnections HashMap.keys st      strs <- traverse (newCString . Text.unpack) networks      newArray0 nullPtr strs @@ -744,17 +746,20 @@  -- | Type of 'glirc_cancel_timer' extension entry-point type Glirc_cancel_timer =-  Ptr ()               {- ^ api token          -} ->-  TimerId              {- ^ timer ID           -} ->-  IO ()+  Ptr ()               {- ^ api token                   -} ->+  TimerId              {- ^ timer ID                    -} ->+  IO (Ptr ())          {- ^ returns held callback state -}  -- | Register a function to be called after a given number of milliseconds -- of delay. The returned timer ID can be used to cancel the timer. glirc_cancel_timer :: Glirc_cancel_timer glirc_cancel_timer stab timerId =   do mvar <- derefToken stab-     modifyMVar_ mvar $ \(i,st) ->-       let st' = overStrict (clientExtensions . esActive . singular (ix i))-                            (cancelTimer (fromIntegral timerId))-                            st-       in st' `seq` return (i,st')+     modifyMVar mvar $ \(i,st) ->+       let Compose mb = st & clientExtensions . esActive . ix i+                   %%~ \ae -> Compose $+                              do (entry, ae') <- cancelTimer (fromIntegral timerId) ae+                                 return (First (Just entry), ae')+       in return $! case mb of+            Just (First (Just ptr), st') -> ((i,st'), ptr)+            _ -> ((i, st), nullPtr)

@@ -107,27 +107,23 @@  -- | @typedef void stop(void *glirc, void *S)@ type StopExtension =-  Ptr () {- ^ api token       -} ->   Ptr () {- ^ extension state -} ->   IO ()  -- | @typedef enum process_result process_message(void *glirc, void *S, const struct glirc_message *)@ type ProcessMessage =-  Ptr ()     {- ^ api token       -} ->   Ptr ()     {- ^ extention state -} ->   Ptr FgnMsg {- ^ message to send -} ->   IO ProcessResult  -- | @typedef void process_command(void *glirc, void *S, const struct glirc_command *)@ type ProcessCommand =-  Ptr ()     {- ^ api token       -} ->   Ptr ()     {- ^ extension state -} ->   Ptr FgnCmd {- ^ command         -} ->   IO ()  -- | @typedef void process_chat(void *glirc, void *S, const struct glirc_chat *)@ type ProcessChat =-  Ptr ()      {- ^ api token       -} ->   Ptr ()      {- ^ extension state -} ->   Ptr FgnChat {- ^ chat info       -} ->   IO ProcessResult@@ -137,8 +133,6 @@  -- | Callback function when timer triggers type TimerCallback =-  Ptr ()  {- ^ api token       -} ->-  Ptr ()  {- ^ extension state -} ->   Ptr ()  {- ^ timer state     -} ->   TimerId {- ^ timer ID        -} ->   IO ()

@@ -36,18 +36,20 @@ import           Client.Message import           Client.State import           Client.State.Channel+import           Client.State.DCC import qualified Client.State.EditBox as Edit import           Client.State.Extensions import           Client.State.Focus import           Client.State.Network import           Client.State.Window import           Control.Applicative+import           Control.Concurrent.Async (cancel) import           Control.Exception (displayException, try) import           Control.Lens import           Control.Monad import           Data.Foldable import           Data.HashSet (HashSet)-import           Data.List (nub, (\\))+import           Data.List (nub, (\\), elem) import           Data.List.NonEmpty (NonEmpty((:|))) import           Data.List.Split import qualified Data.HashMap.Strict as HashMap@@ -64,6 +66,8 @@ import           Irc.Modes import           LensUtils import           RtsStats (getStats)+import           System.Directory (doesDirectoryExist)+import           System.FilePath ((</>)) import           System.Process  -- | Possible results of running a command@@ -87,7 +91,7 @@   -- | Pair of implementations for executing a command and tab completing one.--- The tab-completion logic is extended with a bool+-- The tab-completion logic is extended with a Bool -- indicating that tab completion should be reversed data CommandImpl a   -- | no requirements@@ -143,10 +147,11 @@   ClientState      {- ^ client state    -} ->   IO CommandResult {- ^ command result  -} execute str st =+  let st' = set clientErrorMsg Nothing st in   case dropWhile (' '==) str of     []          -> commandFailure st-    '/':command -> executeUserCommand Nothing command st-    _           -> executeChat str st+    '/':command -> executeUserCommand Nothing command st'+    _           -> executeChat str st'  -- | Execute command provided by user, resolve aliases if necessary. --@@ -327,7 +332,7 @@    , Command       (pure "reload")-      (optionalArg (simpleToken "filename"))+      (optionalArg (simpleToken "[filename]"))       "Reload the client configuration file.\n\       \\n\       \If \^Bfilename\^B is provided it will be used to reload.\n\@@ -399,7 +404,7 @@    , Command       (pure "url")-      (optionalArg numberArg)+      optionalNumberArg       "Open a URL seen in chat.\n\       \\n\       \The URL is opened using the executable configured under \^Burl-opener\^B.\n\@@ -412,8 +417,14 @@     $ ClientCommand cmdUrl noClientTab    , Command+      (pure "cert")+      (pure ())+      "Show the TLS certificate for the current connection.\n"+    $ NetworkCommand cmdCert noNetworkTab++  , Command       (pure "help")-      (optionalArg (simpleToken "command"))+      (optionalArg (simpleToken "[command]"))       "Show command documentation.\n\       \\n\       \When \^Bcommand\^B is omitted a list of all commands is displayed.\n\@@ -496,7 +507,7 @@    [ Command       (pure "focus")-      (liftA2 (,) (simpleToken "network") (optionalArg (simpleToken "target")))+      (liftA2 (,) (simpleToken "network") (optionalArg (simpleToken "[target]")))       "Change the focused window.\n\       \\n\       \When only \^Bnetwork\^B is specified this switches to the network status window.\n\@@ -566,7 +577,7 @@    , Command       (pure "clear")-      (optionalArg (liftA2 (,) (simpleToken "network") (optionalArg (simpleToken "channel"))))+      (optionalArg (liftA2 (,) (simpleToken "[network]") (optionalArg (simpleToken "[channel]"))))       "Clear a window.\n\       \\n\       \If no arguments are provided the current window is cleared.\n\@@ -579,7 +590,7 @@    , Command       (pure "windows")-      (optionalArg (simpleToken "kind"))+      (optionalArg (simpleToken "[kind]"))       "Show a list of all windows with an optional argument to limit the kinds of windows listed.\n\       \\n\       \\^Bkind\^O: one of \^Bnetworks\^O, \^Bchannels\^O, \^Busers\^O\n\@@ -707,7 +718,7 @@    [ Command       ("join" :| ["j"])-      (liftA2 (,) (simpleToken "channels") (optionalArg (simpleToken "keys")))+      (liftA2 (,) (simpleToken "channels") (optionalArg (simpleToken "[keys]")))       "\^BParameters:\^B\n\       \\n\       \    channels: Comma-separated list of channels\n\@@ -920,7 +931,9 @@       \    Show information about the current channel.\n\       \    Press ESC to exit the channel info window.\n\       \\n\-      \\^BSee also:\^B masks, users\n"+      \    Information includes topic, creation time, URL, and modes.\n\+      \\n\+      \\^BSee also:\^B masks, mode, topic, users\n"     $ ChannelCommand cmdChannelInfo noChannelTab    , Command@@ -929,6 +942,17 @@       "Send a raw IRC command.\n"     $ NetworkCommand cmdQuote simpleNetworkTab +  , 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   ------------------------------------------------------------------------   ] , CommandSection "IRC queries"   ------------------------------------------------------------------------@@ -965,7 +989,7 @@    , Command       (pure "time")-      (optionalArg (simpleToken "servername"))+      (optionalArg (simpleToken "[servername]"))       "Send TIME query to server with given arguments.\n"     $ NetworkCommand cmdTime simpleNetworkTab @@ -977,22 +1001,22 @@    , Command       (pure "lusers")-      (optionalArg (liftA2 (,) (simpleToken "mask") (optionalArg (simpleToken "servername"))))+      (optionalArg (liftA2 (,) (simpleToken "mask") (optionalArg (simpleToken "[servername]"))))       "Send LUSERS query to server with given arguments.\n"     $ NetworkCommand cmdLusers simpleNetworkTab    , Command-      (pure "motd") (optionalArg (simpleToken "servername"))+      (pure "motd") (optionalArg (simpleToken "[servername]"))       "Send MOTD query to server.\n"     $ NetworkCommand cmdMotd simpleNetworkTab    , Command-      (pure "admin") (optionalArg (simpleToken "servername"))+      (pure "admin") (optionalArg (simpleToken "[servername]"))       "Send ADMIN query to server.\n"     $ NetworkCommand cmdAdmin simpleNetworkTab    , Command-      (pure "rules") (optionalArg (simpleToken "servername"))+      (pure "rules") (optionalArg (simpleToken "[servername]"))       "Send RULES query to server.\n"     $ NetworkCommand cmdRules simpleNetworkTab @@ -1007,7 +1031,7 @@     $ NetworkCommand cmdList simpleNetworkTab    , Command-      (pure "version") (optionalArg (simpleToken "servername"))+      (pure "version") (optionalArg (simpleToken "[servername]"))       "Send VERSION query to server.\n"     $ NetworkCommand cmdVersion simpleNetworkTab @@ -1017,7 +1041,7 @@    [ Command       (pure "mode")-      (fromMaybe [] <$> optionalArg (extensionArg "modes" modeParamArgs))+      (fromMaybe [] <$> optionalArg (extensionArg "[modes]" modeParamArgs))       "Sets IRC modes.\n\       \\n\       \Examples:\n\@@ -1031,7 +1055,7 @@       \\n\       \This command has parameter sensitive tab-completion.\n\       \\n\-      \See also: /masks\n"+      \See also: /masks /channelinfo\n"     $ NetworkCommand cmdMode tabMode    , Command@@ -1110,7 +1134,7 @@    , Command       (pure "znc-playback")-      (optionalArg (liftA2 (,) (simpleToken "time") (optionalArg (simpleToken "date"))))+      (optionalArg (liftA2 (,) (simpleToken "[time]") (optionalArg (simpleToken "[date]"))))       "Request playback from the ZNC 'playback' module.\n\       \\n\       \\^Btime\^B determines the time to playback since.\n\@@ -1159,11 +1183,17 @@    , Command       (pure "testmask")-      (liftA2 (,) (simpleToken "[nick!]user@host") (optionalArg (simpleToken "gecos")))+      (liftA2 (,) (simpleToken "[nick!]user@host") (optionalArg (simpleToken "[gecos]")))       "Test how many local and global clients match a mask.\n"     $ NetworkCommand cmdTestmask simpleNetworkTab    , Command+      (pure "masktrace")+      (liftA2 (,) (simpleToken "[nick!]user@host") (optionalArg (simpleToken "[gecos]")))+      "Outputs a list of local users matching the given masks.\n"+    $ NetworkCommand cmdMasktrace simpleNetworkTab++  , Command       (pure "map")       (pure ())       "Display network map.\n"@@ -1283,6 +1313,78 @@       do sendMsg cs raw          commandSuccess st +-- | 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 = 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)++ -- | Implementation of @/me@ cmdMe :: ChannelCommand String cmdMe channelId cs st rest =@@ -1587,7 +1689,7 @@ tabConnect isReversed st _ =   simpleTabCompletion plainWordCompleteMode [] networks isReversed st   where-    networks = views clientNetworkMap               HashMap.keys st+    networks = views clientConnections              HashMap.keys st             ++ views (clientConfig . configServers) HashMap.keys st  @@ -1597,7 +1699,7 @@ tabFocus isReversed st _ =   simpleTabCompletion plainWordCompleteMode [] completions isReversed st   where-    networks   = map mkId $ HashMap.keys $ view clientNetworkMap st+    networks   = map mkId $ HashMap.keys $ view clientConnections st     params     = words $ uncurry take $ clientLine st      completions =@@ -1714,6 +1816,11 @@   do sendMsg cs (ircTestmask (Text.pack mask) (maybe "" Text.pack gecos))      commandSuccess st +cmdMasktrace :: NetworkCommand (String, Maybe String)+cmdMasktrace cs st (mask, gecos) =+  do sendMsg cs (ircMasktrace (Text.pack mask) (maybe "*" Text.pack gecos))+     commandSuccess st+ cmdAway :: NetworkCommand String cmdAway cs st rest =   do sendMsg cs (ircAway (Text.pack rest))@@ -1811,9 +1918,9 @@  commandSuccessUpdateCS :: NetworkState -> ClientState -> IO CommandResult commandSuccessUpdateCS cs st =-  do let networkId = view csNetworkId cs+  do let network = view csNetwork cs      commandSuccess-       $ setStrict (clientConnections . ix networkId) cs st+       $ setStrict (clientConnection network) cs st  cmdTopic :: ChannelCommand String cmdTopic channelId cs st rest =@@ -2283,7 +2390,7 @@       foldM (\st1 msg ->            case parseRawIrcMsg msg of              Nothing ->-               return $! recordError now st1 ("Bad raw message: " <> msg)+               return $! recordError now "" ("Bad raw message: " <> msg) st1              Just raw ->                do sendMsg cs raw                   return st1) st msgs@@ -2302,15 +2409,7 @@          preview (clientConnection network) st      failure now es =-      commandFailure $! foldl' (recordError now) st (map Text.pack es)--recordError :: ZonedTime -> ClientState -> Text -> ClientState-recordError now ste e =-  recordNetworkMessage ClientMessage-    { _msgTime    = now-    , _msgBody    = ErrorBody e-    , _msgNetwork = ""-    } ste+      commandFailure $! foldl' (flip (recordError now "")) st (map Text.pack es)  recordSuccess :: ZonedTime -> ClientState -> Text -> ClientState recordSuccess now ste m =@@ -2344,7 +2443,7 @@        Left e  -> commandFailureMsg (Text.pack (displayException (e :: IOError))) st        Right{} -> commandSuccess st --- | Implementation of @/grep@ and @/grepi@+-- | Implementation of @/grep@ cmdGrep :: ClientCommand String cmdGrep st str   | null str  = commandSuccess (set clientRegex Nothing st)@@ -2357,3 +2456,6 @@ cmdOper cs st (user, pass) =   do sendMsg cs (ircOper (Text.pack user) (Text.pack pass))      commandSuccess st++cmdCert :: NetworkCommand ()+cmdCert _ st _ = commandSuccess (changeSubfocus FocusCert st)

@@ -16,6 +16,7 @@   , optionalArg   , tokenList   , numberArg+  , optionalNumberArg   , extensionArg    , ArgumentShape(..)@@ -53,6 +54,9 @@  numberArg :: Args r Int numberArg = tokenArg "number" (\_ -> readMaybe)++optionalNumberArg :: Args r (Maybe Int)+optionalNumberArg = optionalArg (tokenArg "[number]" (\_ -> readMaybe))  tokenList ::   [String] {- ^ required names -} ->

@@ -102,13 +102,14 @@ runExecCmd ::   ExecCmd                       {- ^ exec configuration          -} ->   IO (Either [String] [String]) {- ^ error lines or output lines -}-runExecCmd e =-  do res <- try (readProcess (view execCommand e)-                             (view execArguments e)-                             (view execStdIn e))-     return $ case res of-       Left er -> Left [show (er :: IOError)]-       Right x -> Right (lines x)+runExecCmd cmd =+  do res <- try (readProcessWithExitCode+                   (view execCommand   cmd)+                   (view execArguments cmd)+                   (view execStdIn     cmd))+     return $! case res of+       Left er                  -> Left [displayException (er :: IOError)]+       Right (_code, out, _err) -> Right (lines out)  -- | Power words is similar to 'words' except that when it encounters -- a word formatted as a Haskell 'String' literal it parses it as

@@ -3,6 +3,7 @@ {-# LANGUAGE RecordWildCards   #-} {-# LANGUAGE TemplateHaskell   #-} {-# LANGUAGE ApplicativeDo     #-}+{-# LANGUAGE RankNTypes        #-}  {-| Module      : Client.Configuration@@ -29,6 +30,7 @@   , configPalette   , configWindowNames   , configNickPadding+  , configDownloadDir   , configMacros   , configExtensions   , configExtraHighlights@@ -71,6 +73,7 @@ import           Config import           Config.Schema import           Control.Exception+import           Control.Monad                       (unless) import           Control.Lens                        hiding (List) import           Data.Foldable                       (toList, find) import           Data.Functor.Alt                    ((<!>))@@ -86,6 +89,7 @@ import qualified Data.Text.IO                        as Text import qualified Data.Vector                         as Vector import           Graphics.Vty.Input.Events (Modifier(..), Key(..))+import           Graphics.Vty.Attributes             (Attr) import           Irc.Identifier                      (Identifier) import           System.Directory import           System.FilePath@@ -102,6 +106,7 @@   , _configWindowNames     :: Text -- ^ Names of windows, used when alt-jumping)   , _configExtraHighlights :: HashSet Identifier -- ^ Extra 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@@ -228,6 +233,7 @@ loadConfiguration mbPath = try $   do (path,txt) <- readConfigurationFile mbPath      def  <- loadDefaultServerSettings+     home <- getHomeDirectory       rawcfg <-        case parse txt of@@ -241,7 +247,8 @@                 $ Text.unlines                 $ map explainLoadError (toList es)        Right cfg ->-         do cfg' <- resolvePaths path (cfg def)+         do cfg' <- resolvePaths path (cfg def home)+                    >>= validateDirectories path             return (path, cfg')  @@ -278,10 +285,26 @@                                 . over (ssLogDir        . mapped) res      return $! over (configExtensions . mapped . extensionPath) res              . over (configServers    . mapped) resolveServerFilePaths+             . over configDownloadDir res              $ cfg +-- | 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 ::-  ValueSpecs (ServerSettings -> Configuration)+  ValueSpecs (ServerSettings -> FilePath -> Configuration) configurationSpec = sectionsSpec "" $    do let sec' def name spec info = fromMaybe def <$> optSection' name spec info@@ -322,10 +345,13 @@                                "Initial setting for window layout"      _configShowPing        <- sec' True "show-ping" yesOrNoSpec                                "Initial setting for visibility of ping times"-     return (\def ->+     maybeDownloadDir       <- optSection' "download-dir" stringSpec+                               "Path to DCC download directoy. Defaults to home directory."+     return (\def home ->              let _configDefaults = 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@@ -422,11 +448,33 @@   (ala Endo (foldMap . foldMap) ?? defaultPalette) <$> sequenceA fields    where-    nickColorsSpec = set palNicks . Vector.fromList . NonEmpty.toList <$> nonemptySpec attrSpec+    nickColorsSpec :: ValueSpecs (Palette -> Palette)+    nickColorsSpec = set palNicks . Vector.fromList . NonEmpty.toList+                 <$> nonemptySpec attrSpec +    modeColorsSpec :: Lens' Palette (HashMap Char Attr) -> ValueSpecs (Palette -> Palette)+    modeColorsSpec l+      = fmap (set l)+      $ customSpec "modes" (assocSpec attrSpec)+      $ fmap HashMap.fromList+      . traverse (\(mode, attr) ->+          case Text.unpack mode of+            [m] -> Just (m, attr)+            _   -> Nothing)+     fields :: [SectionSpecs (Maybe (Palette -> Palette))]     fields = optSection' "nick-colors" nickColorsSpec              "Colors used to highlight nicknames"++           : optSection' "cmodes" (modeColorsSpec palCModes)+             "Colors used to highlight channel modes"++           : optSection' "umodes" (modeColorsSpec palUModes)+             "Colors used to highlight user modes"++           : optSection' "snomask" (modeColorsSpec palSnomask)+             "Colors used to highlight server notice mask"+            : [ optSection' lbl (set l <$> attrSpec) "" | (lbl, Lens l) <- paletteMap ]  extensionSpec :: ValueSpecs ExtensionConfiguration

@@ -49,12 +49,15 @@   , ssLogDir   , ssProtocolFamily   , ssSts+  , ssTlsPubkeyFingerprint+  , ssTlsCertFingerprint    -- * Load function   , loadDefaultServerSettings    -- * TLS settings   , UseTls(..)+  , Fingerprint(..)    ) where @@ -63,14 +66,19 @@ import           Client.Configuration.Macros (macroCommandSpec) import           Config.Schema.Spec import           Control.Lens+import qualified Data.ByteString as B import           Data.Functor.Alt                    ((<!>)) import           Data.List.NonEmpty (NonEmpty)+import           Data.ByteString (ByteString) import           Data.Maybe (fromMaybe) import           Data.Monoid import           Data.Text (Text)+import           Data.List.Split (chunksOf, splitOn) import qualified Data.Text as Text+import           Data.Word (Word8) import           Irc.Identifier (Identifier, mkId) import           Network.Socket (HostName, PortNumber, Family(..))+import           Numeric (readHex) import           System.Environment  -- | Static server-level settings@@ -104,6 +112,8 @@   , _ssLogDir           :: Maybe FilePath -- ^ Directory to save logs of chat   , _ssProtocolFamily   :: Maybe Family -- ^ Protocol family to connect with   , _ssSts              :: !Bool -- ^ Honor STS policies when true+  , _ssTlsPubkeyFingerprint :: !(Maybe Fingerprint) -- ^ optional acceptable public key fingerprint+  , _ssTlsCertFingerprint   :: !(Maybe Fingerprint) -- ^ optional acceptable certificate fingerprint   }   deriving Show @@ -114,6 +124,13 @@   | UseInsecure    -- ^ Plain connection   deriving Show +-- | Fingerprint used to validate server certificates.+data Fingerprint+  = FingerprintSha1   ByteString -- ^ SHA-1 fingerprint+  | FingerprintSha256 ByteString -- ^ SHA-2 256-bit fingerprint+  | FingerprintSha512 ByteString -- ^ SHA-2 512-bit fingerprint+  deriving Show+ makeLenses ''ServerSettings  -- | Load the defaults for server settings based on the environment@@ -154,6 +171,8 @@        , _ssLogDir           = Nothing        , _ssProtocolFamily   = Nothing        , _ssSts              = True+       , _ssTlsPubkeyFingerprint = Nothing+       , _ssTlsCertFingerprint   = Nothing        }  serverSpec :: ValueSpecs (ServerSettings -> ServerSettings)@@ -261,8 +280,42 @@        , req "sts" ssSts yesOrNoSpec         "Honor server STS policies forcing TLS connections"++      , opt "tls-cert-fingerprint" ssTlsCertFingerprint fingerprintSpec+        "Check SHA1, SHA256, or SHA512 certificate fingerprint"++      , opt "tls-pubkey-fingerprint" ssTlsPubkeyFingerprint fingerprintSpec+        "Check SHA1, SHA256, or SHA512 public key fingerprint"       ] +-- | Match fingerprints in plain hex or colon-delimited bytes.+-- SHA-1 is 20 bytes. SHA-2-256 is 32 bytes. SHA-2-512 is 64 bytes.+--+-- @+-- 00112233aaFF+-- 00:11:22:33:aa:FF+-- @+fingerprintSpec :: ValueSpecs Fingerprint+fingerprintSpec =+  customSpec "fingerprint" stringSpec $ \str ->+    do bytes <- B.pack <$> traverse readWord8 (byteStrs str)+       case B.length bytes of+         20 -> Just (FingerprintSha1   bytes)+         32 -> Just (FingerprintSha256 bytes)+         64 -> Just (FingerprintSha512 bytes)+         _  -> Nothing+  where+    -- read a single byte in hex+    readWord8 :: String -> Maybe Word8+    readWord8 i =+      case readHex i of+        [(x,"")] | 0 <= x, x < 256 -> Just (fromIntegral (x :: Integer))+        _                           -> Nothing++    byteStrs :: String -> [String]+    byteStrs str+      | ':' `elem` str = splitOn ":" str+      | otherwise      = chunksOf 2  str  -- | Specification for IP protocol family. protocolFamilySpec :: ValueSpecs Family

@@ -16,15 +16,14 @@   , updateTerminalSize   ) where -import qualified Client.Authentication.Ecdsa as Ecdsa import           Client.CApi (popTimer) import           Client.Commands-import           Client.Commands.Interpolation-import           Client.Configuration (configJumpModifier, configKeyMap, configWindowNames)+import           Client.Network.Async (recv)+import           Client.Configuration (configJumpModifier, configKeyMap, configWindowNames, configDownloadDir) import           Client.Configuration.ServerSettings-import           Client.Configuration.Sts import           Client.EventLoop.Actions import           Client.EventLoop.Errors (exceptionToLines)+import           Client.EventLoop.Network (clientResponse) import           Client.Hook import           Client.Hooks import           Client.Image@@ -32,8 +31,8 @@ import           Client.Log import           Client.Message import           Client.Network.Async-import           Client.Network.Connect (ircPort) import           Client.State+import           Client.State.DCC import qualified Client.State.EditBox     as Edit import           Client.State.Extensions import           Client.State.Focus@@ -44,31 +43,32 @@ import           Control.Monad import           Data.ByteString (ByteString) import           Data.Foldable+import           Data.Traversable import           Data.List+import           Data.List.NonEmpty (NonEmpty, nonEmpty) import           Data.Maybe import           Data.Ord import           Data.Text (Text)+import qualified Data.HashMap.Strict as HashMap import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding.Error as Text-import qualified Data.Text.Read as Text import           Data.Time import           GHC.IO.Exception (IOErrorType(..), ioe_type) import           Graphics.Vty-import           Irc.Codes-import           Irc.Commands import           Irc.Message import           Irc.RawIrcMsg import           LensUtils-import           Hookup+import           Hookup (ConnectionFailure(..))  --- | Sum of the three possible event types the event loop handles+-- | Sum of the five possible event types the event loop handles data ClientEvent-  = VtyEvent Event -- ^ Key presses and resizing-  | NetworkEvent NetworkEvent -- ^ Incoming network events-  | TimerEvent NetworkId TimedAction -- ^ Timed action and the applicable network-  | ExtTimerEvent Int -- ^ extension ID+  = VtyEvent Event                        -- ^ Key presses and resizing+  | 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   -- | Block waiting for the next 'ClientEvent'. This function will compute@@ -79,14 +79,18 @@   IO ClientEvent getEvent vty st =   do timer <- prepareTimer-     atomically $-       asum [ timer-            , VtyEvent     <$> readTChan vtyEventChannel-            , NetworkEvent <$> readTQueue (view clientEvents st)-            ]+     atomically (asum [timer, vtyEvent, networkEvents, dccUpdate])   where-    vtyEventChannel = _eventChannel (inputIface vty)+    vtyEvent = VtyEvent <$> readTChan (_eventChannel (inputIface vty)) +    networkEvents =+      do xs <- for (HashMap.toList (view clientConnections st)) $ \(network, conn) ->+           do ys <- recv (view csSocket conn)+              return (map ((,) network) ys)+         case nonEmpty (concat xs) of+           Just events1 -> return (NetworkEvents events1)+           Nothing      -> retry+     prepareTimer =       case earliestEvent st of         Nothing -> return retry@@ -98,6 +102,8 @@                          unless ready retry                          return event +    dccUpdate = DCCUpdate <$> readTChan (view clientDCCUpdates st)+ -- | Compute the earliest scheduled timed action for the client earliestEvent :: ClientState -> Maybe (UTCTime, ClientEvent) earliestEvent st = earliest2 networkEvent extensionEvent@@ -132,17 +138,26 @@       event <- getEvent vty st'      case event of-       ExtTimerEvent i -> eventLoop vty =<< clientExtTimer i st'-       TimerEvent networkId action  -> eventLoop vty =<< doTimerEvent networkId action st'-       VtyEvent vtyEvent -> traverse_ (eventLoop vty) =<< doVtyEvent vty vtyEvent st'-       NetworkEvent networkEvent ->-         eventLoop vty =<<-         case networkEvent of-           NetworkLine  net time line -> doNetworkLine  net time line st'-           NetworkError net time ex   -> doNetworkError net time ex st'-           NetworkOpen  net time      -> doNetworkOpen  net time st'-           NetworkClose net time      -> doNetworkClose net time st'+       ExtTimerEvent i ->+         eventLoop vty =<< clientExtTimer i 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+doNetworkEvent st (net, networkEvent) =+  case networkEvent of+    NetworkLine  time line -> doNetworkLine  net time line st+    NetworkError time ex   -> doNetworkError net time ex st+    NetworkOpen  time msg  -> doNetworkOpen  net time msg st+    NetworkClose time      -> doNetworkClose net time st+ -- | Sound the terminal bell assuming that the @BEL@ control code -- is supported. beep :: Vty -> IO ()@@ -154,11 +169,12 @@  -- | Respond to a network connection successfully connecting. doNetworkOpen ::-  NetworkId   {- ^ network id   -} ->+  Text        {- ^ network name -} ->   ZonedTime   {- ^ event time   -} ->+  [Text]      {- ^ rendered certificate -} ->   ClientState {- ^ client state -} ->   IO ClientState-doNetworkOpen networkId time st =+doNetworkOpen networkId time cert st =   case view (clientConnections . at networkId) st of     Nothing -> error "doNetworkOpen: Network missing"     Just cs ->@@ -167,14 +183,14 @@                      , _msgNetwork = view csNetwork cs                      , _msgBody    = NormalBody "connection opened"                      }+         let cs' = cs & csLastReceived .~ (Just $! zonedTimeToUTC time)+                      & csCertificate  .~ cert          return $! recordNetworkMessage msg-                 $ overStrict (clientConnections . ix networkId . csLastReceived)-                              (\old -> old `seq` Just $! zonedTimeToUTC time)-                              st+                 $ setStrict (clientConnections . ix networkId) cs' st  -- | Respond to a network connection closing normally. doNetworkClose ::-  NetworkId   {- ^ network id   -} ->+  Text        {- ^ network name -} ->   ZonedTime   {- ^ event time   -} ->   ClientState {- ^ client state -} ->   IO ClientState@@ -190,14 +206,14 @@  -- | Respond to a network connection closing abnormally. doNetworkError ::-  NetworkId     {- ^ failed network     -} ->+  Text          {- ^ failed network     -} ->   ZonedTime     {- ^ current time       -} ->   SomeException {- ^ termination reason -} ->   ClientState   {- ^ client state       -} ->   IO ClientState doNetworkError networkId time ex st =   do let (cs,st1) = removeNetwork networkId st-         st2 = foldl' (\acc msg -> recordError time cs (Text.pack msg) acc) st1+         st2 = foldl' (\acc msg -> recordError time (view csNetwork cs) (Text.pack msg) acc) st1              $ exceptionToLines ex      reconnectLogic ex cs st2 @@ -238,7 +254,7 @@ -- | Respond to an IRC protocol line. This will parse the message, updated the -- relevant connection state and update the UI buffers. doNetworkLine ::-  NetworkId   {- ^ Network ID of message            -} ->+  Text        {- ^ Network name                     -} ->   ZonedTime   {- ^ current time                     -} ->   ByteString  {- ^ Raw IRC message without newlines -} ->   ClientState {- ^ client state                     -} ->@@ -251,7 +267,7 @@       case parseRawIrcMsg (asUtf8 line) of         Nothing ->           do let msg = Text.pack ("Malformed message: " ++ show line)-             return $! recordError time cs msg st+             return $! recordError time (view csNetwork cs) msg st          Just raw ->           do (st1,passed) <- clientNotifyExtensions network raw st@@ -285,147 +301,14 @@                                         , _msgBody    = IrcBody irc'                                         } -                    let (replies, st3) = applyMessageToClientState time irc networkId cs st2+                    let (replies, dccUp, st3) =+                          applyMessageToClientState time irc networkId cs st2 +                    traverse_ (atomically . writeTChan (view clientDCCUpdates st3)) dccUp                     traverse_ (sendMsg cs) replies                     clientResponse time' irc cs st3  --- | Client-level responses to specific IRC messages.--- This is in contrast to the connection state tracking logic in--- "Client.NetworkState"-clientResponse :: ZonedTime -> IrcMsg -> NetworkState -> ClientState -> IO ClientState-clientResponse now irc cs st =-  case irc of-    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)-                      (set clientFocus focus st)-                      (view (csSettings . ssConnectCmds) cs)-         return $! set clientFocus (view clientFocus st) st'--    Authenticate challenge-      | AS_EcdsaWaitChallenge <- view csAuthenticationState cs ->-         processSaslEcdsa now challenge cs st--    Cap (CapLs _ caps)-      | Just stsVal <- join (lookup "sts" caps) -> processSts stsVal cs st--    Cap (CapNew caps)-      | Just stsVal <- join (lookup "sts" caps) -> processSts stsVal cs st--    _ -> return st---processSts ::-  Text         {- ^ STS parameter string -} ->-  NetworkState {- ^ network state        -} ->-  ClientState  {- ^ client state         -} ->-  IO ClientState-processSts txt cs st =-  case view (csSettings . ssTls) cs of-    _ | views (csSettings . ssSts) not cs        -> return st -- sts disabled-    UseInsecure    | Just port     <- mbPort     -> upgradeConnection port-    UseTls         | Just duration <- mbDuration -> setStsPolicy duration-    UseInsecureTls | Just duration <- mbDuration -> setStsPolicy duration-    _                                            -> return st--  where-    entries    = splitEntry <$> Text.splitOn "," txt-    mbPort     = readInt =<< lookup "port"     entries-    mbDuration = readInt =<< lookup "duration" entries--    splitEntry e =-      case Text.break ('=' ==) e of-        (a, b) -> (a, Text.drop 1 b)--    upgradeConnection port =-      do abortConnection StsUpgrade (view csSocket cs)-         addConnection 0 (view csLastReceived cs) (Just port) (view csNetwork cs) st--    setStsPolicy duration =-      do now <- getCurrentTime-         let host = Text.pack (view (csSettings . ssHostName) cs)-             port = fromIntegral (ircPort (view csSettings cs))-             policy = StsPolicy-                        { _stsExpiration = addUTCTime (fromIntegral duration) now-                        , _stsPort       = port }-             st' = st & clientStsPolicy . at host ?~ policy-         savePolicyFile (view clientStsPolicy st')-         return st'---readInt :: Text -> Maybe Int-readInt x =-  case Text.decimal x of-    Right (n, t) | Text.null t -> Just n-    _                          -> Nothing--processSaslEcdsa ::-  ZonedTime    {- ^ message time  -} ->-  Text         {- ^ challenge     -} ->-  NetworkState {- ^ network state -} ->-  ClientState  {- ^ client state  -} ->-  IO ClientState-processSaslEcdsa now challenge cs st =-  case view ssSaslEcdsaFile ss of-    Nothing ->-      do sendMsg cs ircCapEnd-         return $! recordError now cs "panic: ecdsatool malformed output" st--    Just path ->-      do res <- Ecdsa.computeResponse path challenge-         case res of-           Left e ->-             do sendMsg cs ircCapEnd-                return $! recordError now cs (Text.pack e) st-           Right resp ->-             do sendMsg cs (ircAuthenticate resp)-                return $! set asLens AS_None st-  where-    ss = view csSettings cs-    asLens = clientConnections . ix (view csNetworkId cs) . csAuthenticationState---processConnectCmd ::-  ZonedTime       {- ^ now             -} ->-  NetworkState    {- ^ current network -} ->-  ClientState     {- ^ client state    -} ->-  [ExpansionChunk]{- ^ command         -} ->-  IO ClientState-processConnectCmd now cs st0 cmdTxt =-  do dc <- forM disco $ \t ->-             Text.pack . formatTime defaultTimeLocale "%H:%M:%S"-               <$> utcToLocalZonedTime t-     let failureCase e = recordError now cs ("Bad connect-cmd: " <> e)-     case resolveMacroExpansions (commandExpansion dc st0) (const Nothing) cmdTxt of-       Nothing -> return $! failureCase "Unable to expand connect command" st0-       Just cmdTxt' ->-         do res <- executeUserCommand dc (Text.unpack cmdTxt') st0-            return $! case res of-              CommandFailure st -> failureCase cmdTxt' st-              CommandSuccess st -> st-              CommandQuit    st -> st -- not supported- where- disco = case view csPingStatus cs of-   PingConnecting _ tm -> tm-   _ -> Nothing---recordError ::-  ZonedTime       {- ^ now             -} ->-  NetworkState    {- ^ current network -} ->-  Text            {- ^ error message   -} ->-  ClientState     {- ^ client state    -} ->-  ClientState-recordError now cs msg =-  recordNetworkMessage ClientMessage-    { _msgTime    = now-    , _msgNetwork = view csNetwork cs-    , _msgBody    = ErrorBody msg-    }- -- | Find the ZNC provided server time computeEffectiveTime :: ZonedTime -> [TagEntry] -> ZonedTime computeEffectiveTime time tags = fromMaybe time zncTime@@ -590,11 +473,32 @@  -- | Respond to a timer event. doTimerEvent ::-  NetworkId   {- ^ Network related to event -} ->+  Text        {- ^ Network related to event -} ->   TimedAction {- ^ Action to perform        -} ->   ClientState {- ^ client state             -} ->   IO ClientState doTimerEvent networkId action =   traverseOf-    (clientConnections . ix networkId)+    (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

@@ -0,0 +1,162 @@+{-# Language OverloadedStrings #-}+{-|+Module      : Client.EventLoop.Network+Description : Event handlers for network messages affecting the client state+Copyright   : (c) Eric Mertens, 2016+License     : ISC+Maintainer  : emertens@gmail.com++While most network messages only affect the model of that network connection,+some messages will affect the mutable state of the client itself.+-}+module Client.EventLoop.Network+  ( clientResponse+  ) where++import           Client.Commands+import           Client.Commands.Interpolation+import           Client.Configuration.ServerSettings+import           Client.Configuration.Sts+import           Client.Network.Async+import           Client.Network.Connect+import           Client.State+import           Client.State.Focus+import           Client.State.Network+import           Control.Lens+import           Control.Monad+import           Data.Text (Text)+import           Data.Time+import           Irc.Codes+import           Irc.Commands+import           Irc.Identifier+import           Irc.Message+import qualified Client.Authentication.Ecdsa as Ecdsa+import qualified Data.Text as Text+import qualified Data.Text.Read as Text++-- | Client-level responses to specific IRC messages.+-- This is in contrast to the connection state tracking logic in+-- "Client.NetworkState"+clientResponse :: ZonedTime -> IrcMsg -> NetworkState -> ClientState -> IO ClientState+clientResponse now irc cs st =+  case irc of+    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)+                      (set clientFocus focus st)+                      (view (csSettings . ssConnectCmds) cs)+         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 : _)+      | let network = view csNetwork cs+      , view clientFocus st == ChannelFocus network (mkId src) ->+         return $! set clientFocus (ChannelFocus network (mkId dst)) st++    Authenticate challenge+      | AS_EcdsaWaitChallenge <- view csAuthenticationState cs ->+         processSaslEcdsa now challenge cs st++    Cap (CapLs _ caps)+      | Just stsVal <- join (lookup "sts" caps) -> processSts stsVal cs st++    Cap (CapNew caps)+      | Just stsVal <- join (lookup "sts" caps) -> processSts stsVal cs st++    _ -> return st+++processSts ::+  Text         {- ^ STS parameter string -} ->+  NetworkState {- ^ network state        -} ->+  ClientState  {- ^ client state         -} ->+  IO ClientState+processSts txt cs st =+  case view (csSettings . ssTls) cs of+    _ | views (csSettings . ssSts) not cs        -> return st -- sts disabled+    UseInsecure    | Just port     <- mbPort     -> upgradeConnection port+    UseTls         | Just duration <- mbDuration -> setStsPolicy duration+    UseInsecureTls | Just duration <- mbDuration -> setStsPolicy duration+    _                                            -> return st++  where+    entries    = splitEntry <$> Text.splitOn "," txt+    mbPort     = readInt =<< lookup "port"     entries+    mbDuration = readInt =<< lookup "duration" entries++    splitEntry e =+      case Text.break ('=' ==) e of+        (a, b) -> (a, Text.drop 1 b)++    upgradeConnection port =+      do abortConnection StsUpgrade (view csSocket cs)+         addConnection 0 (view csLastReceived cs) (Just port) (view csNetwork cs) st++    setStsPolicy duration =+      do now <- getCurrentTime+         let host = Text.pack (view (csSettings . ssHostName) cs)+             port = fromIntegral (ircPort (view csSettings cs))+             policy = StsPolicy+                        { _stsExpiration = addUTCTime (fromIntegral duration) now+                        , _stsPort       = port }+             st' = st & clientStsPolicy . at host ?~ policy+         savePolicyFile (view clientStsPolicy st')+         return st'+++readInt :: Text -> Maybe Int+readInt x =+  case Text.decimal x of+    Right (n, t) | Text.null t -> Just n+    _                          -> Nothing++processSaslEcdsa ::+  ZonedTime    {- ^ message time  -} ->+  Text         {- ^ challenge     -} ->+  NetworkState {- ^ network state -} ->+  ClientState  {- ^ client state  -} ->+  IO ClientState+processSaslEcdsa now challenge cs st =+  case view ssSaslEcdsaFile ss of+    Nothing ->+      do sendMsg cs ircCapEnd+         return $! recordError now (view csNetwork cs) "panic: ecdsatool malformed output" st++    Just path ->+      do res <- Ecdsa.computeResponse path challenge+         case res of+           Left e ->+             do sendMsg cs ircCapEnd+                return $! recordError now (view csNetwork cs) (Text.pack e) st+           Right resp ->+             do sendMsg cs (ircAuthenticate resp)+                return $! set asLens AS_None st+  where+    ss = view csSettings cs+    asLens = clientConnection (view csNetwork cs) . csAuthenticationState++processConnectCmd ::+  ZonedTime       {- ^ now             -} ->+  NetworkState    {- ^ current network -} ->+  ClientState     {- ^ client state    -} ->+  [ExpansionChunk]{- ^ command         -} ->+  IO ClientState+processConnectCmd now cs st0 cmdTxt =+  do dc <- forM disco $ \t ->+             Text.pack . formatTime defaultTimeLocale "%H:%M:%S"+               <$> utcToLocalZonedTime t+     let failureCase e = recordError now (view csNetwork cs) ("Bad connect-cmd: " <> e)+     case resolveMacroExpansions (commandExpansion dc st0) (const Nothing) cmdTxt of+       Nothing -> return $! failureCase "Unable to expand connect command" st0+       Just cmdTxt' ->+         do res <- executeUserCommand dc (Text.unpack cmdTxt') st0+            return $! case res of+              CommandFailure st -> failureCase cmdTxt' st+              CommandSuccess st -> st+              CommandQuit    st -> st -- not supported+ where+ disco =+   case view csPingStatus cs of+     PingConnecting _ tm -> tm+     _                   -> Nothing

@@ -0,0 +1,182 @@+{-# Language QuasiQuotes, OverloadedStrings #-}+{-|+Module      : Client.Hook.FreRelay+Description : Hook for interpreting FreFrelay messages+Copyright   : (c) Eric Mertens 2019+License     : ISC+Maintainer  : emertens@gmail.com++The #dronebl channel uses the FreRelay bot to relay messages from+other networks. This hook integrates those messages into the native+format.++-}+module Client.Hook.FreRelay+  ( freRelayHook+  ) where++import           Data.List (uncons)+import qualified Data.Text as Text+import           Data.Text (Text)+import           Data.Foldable (asum)++import           Text.Regex.TDFA (match, defaultCompOpt, defaultExecOpt)+import           Text.Regex.TDFA.Text (Regex, compile)++import           Client.Hook (MessageHook(..), MessageResult(..))+import           Irc.Message+import           Irc.Identifier (mkId, Identifier)+import           Irc.UserInfo (UserInfo(..))+import           StrQuote (str)++freRelayHook :: MessageHook+freRelayHook = MessageHook "frerelay" False remap++-- | Remap messages from frerelay on #dronebl that match one of the+-- rewrite rules.+remap :: IrcMsg -> MessageResult+remap (Privmsg (UserInfo "frerelay" _ _) chan@"#dronebl" msg)+  | Just sub <- rules chan msg = RemapMessage sub+remap _ = PassMessage++-- | Generate a replacement message for a chat message from frerelay+-- when the message matches one of the replacement rules.+rules ::+  Identifier {- ^ channel -} ->+  Text       {- ^ message -} ->+  Maybe IrcMsg+rules chan msg =+  asum+    [ rule (chatMsg chan) chatRe msg+    , rule (actionMsg chan) actionRe msg+    , rule (joinMsg chan) joinRe msg+    , rule (partMsg chan) partRe msg+    , rule quitMsg quitRe msg+    , rule nickMsg nickRe msg+    ]++-- | Match the message against the regular expression and use the given+-- consume to consume all of the captured groups.+rule ::+  Rule r =>+  r     {- ^ capture consumer   -} ->+  Regex {- ^ regular expression -} ->+  Text  {- ^ message            -} ->+  Maybe IrcMsg+rule mk re s =+  case match re s of+    [_:xs] -> matchRule xs mk+    _      -> Nothing++chatRe, actionRe, joinRe, quitRe, nickRe, partRe :: Regex+Right chatRe   = compRe [str|^<([^>]+)> (.*)$|]+Right actionRe = compRe [str|^\* ([^ ]+) (.*)$|]+Right joinRe   = compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) \(([^@]+)@([^)]+)\) has joined the channel$|]+Right quitRe   = compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) has signed off \((.*)\)$|]+Right nickRe   = compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) changed nick to ([^ ]+)$|]+Right partRe   = compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) has left the channel( \((.*)\))?$|]++-- | Compile a regular expression for using in message matching.+compRe ::+  Text                {- ^ regular expression           -} ->+  Either String Regex {- ^ error or compiled expression -}+compRe = compile defaultCompOpt defaultExecOpt++------------------------------------------------------------------------++chatMsg ::+  Identifier {- ^ channel  -} ->+  Text       {- ^ nickname -} ->+  Text       {- ^ message  -} ->+  IrcMsg+chatMsg chan nick msg =+  Privmsg+    (userInfo nick)+    chan+    msg++actionMsg ::+  Identifier {- ^ channel  -} ->+  Text       {- ^ nickname -} ->+  Text       {- ^ message  -} ->+  IrcMsg+actionMsg chan nick msg =+  Ctcp+    (userInfo nick)+    chan+    "ACTION"+    msg++joinMsg ::+  Identifier {- ^ channel  -} ->+  Text       {- ^ server   -} ->+  Text       {- ^ nickname -} ->+  Text       {- ^ username -} ->+  Text       {- ^ hostname -} ->+  IrcMsg+joinMsg chan srv nick user host =+  Join+    (UserInfo (mkId (nick <> "@" <> srv)) user host)+    chan+    "" -- account++partMsg ::+  Identifier {- ^ channel        -} ->+  Text       {- ^ server         -} ->+  Text       {- ^ nickname       -} ->+  Text       {- ^ reason wrapper -} ->+  Text       {- ^ reason         -} ->+  IrcMsg+partMsg chan srv nick msg_outer msg =+  Part+    (userInfo (nick <> "@" <> srv))+    chan+    (if Text.null msg_outer then Nothing else Just msg)++quitMsg ::+  Text {- ^ server       -} ->+  Text {- ^ nickname     -} ->+  Text {- ^ quit message -} ->+  IrcMsg+quitMsg srv nick msg =+  Quit+    (userInfo (nick <> "@" <> srv))+    (Just msg)++nickMsg ::+  Text {- ^ server   -} ->+  Text {- ^ old nick -} ->+  Text {- ^ new nick -} ->+  IrcMsg+nickMsg srv old new =+  Nick+    (userInfo (old <> "@" <> srv))+    (mkId (new <> "@" <> srv))++-- | Construct dummy user info when we don't know the user or host part.+userInfo ::+  Text {- ^ nickname -} ->+  UserInfo+userInfo nick = UserInfo (mkId nick) "*" "*"++------------------------------------------------------------------------++class Rule a where+  matchRule :: [Text] -> a -> Maybe IrcMsg++class RuleArg a where+  matchArg :: Text -> Maybe a++instance RuleArg Text where+  matchArg = Just++instance (RuleArg a, Rule b) => Rule (a -> b) where+  matchRule tts f =+    do (t,ts) <- uncons tts+       a      <- matchArg t+       matchRule ts (f a)++instance Rule IrcMsg where+  matchRule args ircMsg+    | null args = Just ircMsg+    | otherwise = Nothing

@@ -24,7 +24,6 @@ import           Irc.Message import           Irc.Identifier (mkId, Identifier) import           Irc.UserInfo-import           Language.Haskell.TH import           StrQuote (str)  snoticeHook :: MessageHook@@ -36,8 +35,9 @@ remap (Notice (UserInfo u "" "") _ msg)   | Just msg1 <- Text.stripPrefix "*** Notice -- " msg   , let msg2 = Text.filter (\x -> x /= '\x02' && x /= '\x0f') msg1-  , Just (_lvl, cat) <- characterize msg2-  = RemapMessage (Notice (UserInfo u "" "*") cat msg1)+  , Just (lvl, cat) <- characterize msg2+  = if lvl < 1 then OmitMessage+               else RemapMessage (Notice (UserInfo u "" "*") cat msg1)  remap _ = PassMessage @@ -64,4 +64,150 @@  patterns :: [(Int, Identifier, Regex)] patterns = map toPattern-    []+    [+    -- PATTERN LIST, most common snotes+    -- Client connecting, more complete regex: ^Client connecting: [^ ]+ \([^ ]+@[^ ]+\) \[[^ ]+\] \{[^ ]+\} \[.*\]$+    (1, "c", [str|^Client connecting: |]),+    -- Client exiting, more complete regex: ^Client exiting: [^ ]+ \([^ ]+@[^ ]+\) \[.*\] \[[^ ]+\]$+    (0, "c", [str|^Client exiting: |]),+    -- Nick change+    (0, "c", [str|^Nick change: From |]),+    -- Connection limit, more complete regex: ^Too many user connections for [^ ]+![^ ]+@[^ ]+$+    (0, "u", [str|^Too many user connections for |]),+    -- Join alerts, more complete regex: ^User [^ ]+ \([^ ]+@[^ ]+\) trying to join #[^ ]* is a possible spambot$+    (1, "a", [str|^User [^ ]+ \([^ ]+\) trying to join #[^ ]* is a possible spambot|]),+    -- Kline hitting user+    (1, "k", [str|^K/DLINE active for|]),+    -- Connection limit, more complete regex: ^Too many local connections for [^ ]+![^ ]+@[^ ]+$+    (0, "u", [str|^Too many local connections for |]),+    -- Global kline added, more complete regex: ^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} added global [0-9]+ min. K-Line for \[[^ ]+\] \[.*\]$+    (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 |]),+    -- Global kline expiring, more complete regex: ^Propagated ban for \[[^ ]+\] expired$+    (0, "k", [str|^Propagated ban for |]),+    -- Chancreate+    (1, "u", [str|^[^ ]+ is creating new channel #|]),++    -- m_filter+    (0, "u", [str|^FILTER: |]),+    (0, "m", [str|^New filters loaded.$|]),+    (0, "m", [str|^Filtering enabled.$|]),++    -- Failed login+    (0, "f", [str|^Warning: [0-9]+ failed login attempts|]),+    -- Temporary kline added, more complete regex: ^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} added temporary [0-9]+ min. K-Line for \[[^ ]+\] \[.*\]$+    (1, "k", [str|^OperServ![^ ]+\{services\.\} added temporary [0-9]+ min. K-Line for \[[^ ]+\] \[Joining #|]), -- klinechans+    (1, "k", [str|^OperSyn![^ ]+\{syn\.\} added temporary [0-9]+ min. K-Line for \[[^ ]+\] \[You've been temporarily|]), -- lethals+    (2, "k", [str|^[^ ]+ added temporary [0-9]+ min. K-Line for |]),+    -- Nick collision+    (1, "m", [str|^Nick collision on|]),+    -- KILLs+    (0, "k", [str|^Received KILL message for [^ ]+\. From NickServ |]),+    (0, "k", [str|^Received KILL message for [^ ]+\. From [^ .]+\.freenode\.net \(Nickname regained by services\)|]),+    (0, "k", [str|^Received KILL message for [^ ]+\. From syn Path: [^ ]+ \(Facility Blocked\)|]),+    (1, "k", [str|^Received KILL message for [^ ]+\. From syn Path: [^ ]+ \(Banned\)|]),+    (1, "k", [str|^Received KILL message for [^ ]+\. From Sigyn Path: [^ ]+ \(Spam is off topic on freenode\.\)|]),+    (2, "k", [str|^Received KILL message|]),+    -- Teporary kline expiring, more complete regex: ^Temporary K-line for \[[^ ]+\] expired$+    (0, "k", [str|^Temporary K-line for |]),++    -- PATTERN LIST, uncommon snotes. regex performance isn't very important beyond this point+    (2, "a", [str|^Possible Flooder|]),+    (2, "a", [str|^New Max Local Clients: [0-9]+$|]),++    (1, "f", [str|^Failed (OPER|CHALLENGE) attempt - host mismatch|]),+    (3, "f", [str|^Failed (OPER|CHALLENGE) attempt|]), -- ORDER IMPORTANT - catch all failed attempts that aren't host mismatch++    (1, "k", [str|^KLINE active for|]),+    (3, "k", [str|^KLINE over-ruled for |]),+    (2, "k", [str|^[^ ]+ added global [0-9]+ min. K-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 \[[^ ]+\] \[.*\]$|]),++    (0, "m", [str|^Received SAVE message for|]),+    (0, "m", [str|^Ignored noop SAVE message for|]),+    (0, "m", [str|^Ignored SAVE message for|]),+    (0, "m", [str|^TS for #[^ ]+ changed from|]),+    (0, "m", [str|^Nick change collision from |]),+    (0, "m", [str|^Dropping IDENTIFIED|]),+    (1, "m", [str|^Got signal SIGHUP, reloading ircd conf\. file|]),+    (1, "m", [str|^Got SIGHUP; reloading|]),+    (1, "m", [str|^Updating database by request of system console\.$|]),+    (1, "m", [str|^Rehashing .* by request of system console\.$|]),+    (2, "m", [str|^Updating database by request of [^ ]+( \([^ ]+\))?\.$|]),+    (2, "m", [str|^Rehashing .* by request of [^ ]+( \([^ ]+\))?\.$|]),+    (3, "m", [str|^".*", line [0-9+]|]), -- configuration syntax error!+    (0, "m", [str|^Ignoring attempt from [^ ]+( \([^ ]+\))? to set login name for|]),+    (1, "m", [str|^binding listener socket: 99 \(Cannot assign requested address\)$|]),+    (2, "m", [str|^binding listener socket: |]),++    (2, "o", [str|^OPERSPY [^ ]+![^ ]+@[^ ]+\{[^ ]+\} |]),+    (2, "o", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} is overriding |]),+    (2, "o", [str|^[^ ]+ \([^ ]+@[^ ]+\) is now an operator$|]),+    (1, "o", [str|^[^ ]+( \([^ ]+\))? dropped the nick |]),+    (1, "o", [str|^[^ ]+( \([^ ]+\))? dropped the account |]),+    (2, "o", [str|^[^ ]+( \([^ ]+\))? dropped the channel |]),+    (1, "o", [str|^[^ ]+( \([^ ]+\))? set vhost |]),+    (1, "o", [str|^[^ ]+( \([^ ]+\))? deleted vhost |]),+    (2, "o", [str|^[^ ]+( \([^ ]+\))? is using MODE |]),+    (3, "o", [str|^[^ ]+( \([^ ]+\))? froze the account |]),+    (3, "o", [str|^[^ ]+( \([^ ]+\))? thawed the account |]),+    (2, "o", [str|^[^ ]+( \([^ ]+\))? transferred foundership of #|]),+    (2, "o", [str|^[^ ]+( \([^ ]+\))? marked the channel #|]),+    (2, "o", [str|^[^ ]+( \([^ ]+\))? unmarked the channel #|]),+    (2, "o", [str|^[^ ]+( \([^ ]+\))? is forcing flags change |]),+    (3, "o", [str|^[^ ]+( \([^ ]+\))? is clearing channel #|]),+    (2, "o", [str|^[^ ]+( \([^ ]+\))? closed the channel #|]),+    (2, "o", [str|^[^ ]+( \([^ ]+\))? reopened the channel #|]),+    (2, "o", [str|^[^ ]+( \([^ ]+\))? reopened #|]),+    (3, "o", [str|^[^ ]+( \([^ ]+\))? reset the password for the account|]),+    (3, "o", [str|^[^ ]+( \([^ ]+\))? enabled automatic klines on the channel|]),+    (3, "o", [str|^[^ ]+( \([^ ]+\))? forbade the nickname |]),+    (3, "o", [str|^[^ ]+( \([^ ]+\))? unforbade the nickname |]),+    (3, "o", [str|^[^ ]+( \([^ ]+\))? is removing oper class for |]),+    (3, "o", [str|^[^ ]+( \([^ ]+\))? is changing oper class for |]),+    (3, "o", [str|^[^ ]+( \([^ ]+\))? set the REGNOLIMIT option for the account |]),+    (3, "o", [str|^[^ ]+( \([^ ]+\))? set the HOLD option for the account |]),+    (3, "o", [str|^[^ ]+( \([^ ]+\))? returned the account |]),+    (1, "o", [str|^Not kicking immune user |]),+    (1, "o", [str|^Not kicking oper |]),+    (1, "o", [str|^Overriding KICK from |]),+    (1, "o", [str|^Server [^ ]+ split from |]),+    (3, "o", [str|^Netsplit [^ ]+ <->|]),+    (2, "o", [str|^Remote SQUIT|]),+    (3, "o", [str|^ssld error for |]),+    (1, "o", [str|^Finished synchronizing with network|]),+    (3, "o", [str|^Link [^ ]+ notable TS delta|]),+    (1, "o", [str|^End of burst \(emulated\) from |]),+    (2, "o", [str|^Link with [^ ]+ established: |]),+    (2, "o", [str|^Connection to [^ ]+ activated$|]),+    (2, "o", [str|^Attempt to re-introduce|]),+    (1, "o", [str|^Server [^ ]+ being introduced|]),+    (2, "o", [str|^Netjoin [^ ]+ <->|]),+    (2, "o", [str|^Error connecting to|]),+    (1, "o", [str|^[^ ]+![^ ]+@[^ ]+ is sending resvs and xlines|]),+    (3, "o", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} is changing the privilege set|]),+    (3, "o", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} is opering |]),+    (3, "o", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} is deopering |]),+    (3, "o", [str|^[^ ]+ is using DEHELPER |]),+    (3, "o", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} is clearing the nick delay table|]),+    (3, "o", [str|^Module |]),+    (3, "o", [str|^Cannot locate module |]),+    (2, "o", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} is adding a permanent X-Line for \[.*\]|]),+    (2, "o", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} added X-Line for \[.*\]|]),+    (2, "o", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} is adding a permanent RESV for \[.*\]|]),+    (2, "o", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} added 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 |]),+    (3, "o", [str|^No response from [^ ]+, closing link$|]),++    (0, "u", [str|^Too many global connections for [^ ]+![^ ]+@[^ ]+$|]),+    (0, "u", [str|^Invalid username: |]),+    (0, "u", [str|^HTTP Proxy disconnected: |]),+    (2, "u", [str|^Unauthorised client connection from |]),+    (2, "u", [str|^[^ ]+( \([^ ]+\))? sent the password for the MARKED account|]),+    (2, "u", [str|^Not restoring mark|])]+-- -}

@@ -19,6 +19,7 @@ import Data.HashMap.Strict import Client.Hook +import Client.Hook.FreRelay import Client.Hook.Snotice import Client.Hook.Znc.Buffextras @@ -28,4 +29,5 @@   [ ("snotice", snoticeHook)   , ("buffextras", buffextrasHook False)   , ("buffextras-debug", buffextrasHook True)+  , ("frerelay", freRelayHook)   ]

@@ -34,6 +34,7 @@ import           Client.Image.PackedImage import           Client.Image.Palette import           Client.Message+import           Client.State.DCC (isSend) import           Client.State.Window import           Control.Lens import           Data.Char@@ -77,7 +78,7 @@ -- render parameters. msgImage ::   ZonedTime                {- ^ time of message     -} ->-  MessageRendererParams    {- render parameters     -} ->+  MessageRendererParams    {- ^ render parameters   -} ->   MessageBody              {- ^ message body        -} ->   (Image', Image', Image') {- ^ prefix, image, full -} msgImage when params body = (prefix, image, full)@@ -231,9 +232,12 @@       string (withForeColor defAttr red) ":"      Privmsg src _ _ -> who src <> ":"+    Wallops src _   -> who src <> "!!"      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 ->@@ -287,12 +291,13 @@     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     Ctcp {}                     -> mempty     CtcpNotice _ _ cmd      txt -> parseIrcText cmd <> " " <>                                    parseIrcTextWithNicks pal myNicks nicks False txt -    Reply code params -> renderReplyCode NormalRender code params+    Reply code params -> renderReplyCode pal NormalRender code params     UnknownMsg irc ->       text' defAttr (view msgCommand irc) <>       char defAttr ' ' <>@@ -372,6 +377,11 @@       who src <> ": " <>       parseIrcTextWithNicks pal myNicks nicks False txt +    Wallops src txt ->+      string quietAttr "wall " <>+      who src <> ": " <>+      parseIrcTextWithNicks pal myNicks nicks False txt+     Ctcp src _dst "ACTION" txt ->       string quietAttr "actp " <>       string (withForeColor defAttr blue) "* " <>@@ -403,7 +413,7 @@       parseIrcText reason      Reply code params ->-      renderReplyCode DetailedRender code params+      renderReplyCode pal DetailedRender code params      UnknownMsg irc ->       foldMap (\ui -> coloredUserInfo pal rm myNicks ui <> char defAttr ' ')@@ -475,20 +485,36 @@      attr = withForeColor defAttr color -renderReplyCode :: RenderMode -> ReplyCode -> [Text] -> Image'-renderReplyCode rm code@(ReplyCode w) params =+renderReplyCode :: Palette -> RenderMode -> ReplyCode -> [Text] -> Image'+renderReplyCode pal rm code@(ReplyCode w) params =   case rm of     DetailedRender -> string attr (shows w " ") <> rawParamsImage     NormalRender   ->       case code of+        RPL_WHOISUSER    -> whoisUserParamsImage+        RPL_WHOWASUSER   -> whoisUserParamsImage+        RPL_WHOISACTUALLY-> param_3_4_Image         RPL_WHOISIDLE    -> whoisIdleParamsImage-        RPL_TOPIC        -> topicParamsImage+        RPL_WHOISCHANNELS-> param_3_3_Image+        RPL_WHOISACCOUNT -> param_3_4_Image+        RPL_WHOISSERVER  -> whoisServerParamsImage+        RPL_WHOISSECURE  -> param_3_3_Image+        RPL_WHOISOPERATOR-> param_3_3_Image+        RPL_WHOISCERTFP  -> param_3_3_Image+        RPL_WHOISSPECIAL -> param_3_3_Image+        RPL_WHOISHOST    -> param_3_3_Image+        RPL_ENDOFWHOIS   -> ""+        RPL_ENDOFWHOWAS  -> ""+        RPL_TOPIC        -> param_3_3_Image         RPL_TOPICWHOTIME -> topicWhoTimeParamsImage-        RPL_CHANNEL_URL  -> channelUrlParamsImage+        RPL_CHANNEL_URL  -> param_3_3_Image         RPL_CREATIONTIME -> creationTimeParamsImage-        RPL_INVITING     -> invitingParamsImage+        RPL_INVITING     -> params_2_3_Image+        RPL_TESTLINE     -> testlineParamsImage         _                -> rawParamsImage   where+    label t = text' (view palLabel pal) t <> ": "+     rawParamsImage = separatedParams params'      params' = case rm of@@ -505,46 +531,75 @@      attr = withForeColor defAttr color -    invitingParamsImage =+    params_2_3_Image =       case params of-        [_, user, _] -> text' defAttr user-        _ -> rawParamsImage+        [_, p, _] -> parseIrcText' False p+        _         -> rawParamsImage -    topicParamsImage =+    param_3_3_Image =       case params of-        [_, _, topic] -> text' defAttr topic-        _ -> rawParamsImage+        [_, _, txt] -> parseIrcText' False txt+        _           -> rawParamsImage +    param_3_4_Image =+      case params of+        [_, _, p, _] -> parseIrcText' False p+        _            -> rawParamsImage+     topicWhoTimeParamsImage =       case params of         [_, _, who, time] ->-          text' defAttr "set by " <>+          label "set by" <>           text' defAttr who <>-          text' defAttr " at " <>+          label " at" <>           string defAttr (prettyUnixTime (Text.unpack time))         _ -> rawParamsImage -    channelUrlParamsImage =+    creationTimeParamsImage =       case params of-        [_, _, url] -> text' defAttr url+        [_, _, time, _] -> string defAttr (prettyUnixTime (Text.unpack time))         _ -> rawParamsImage -    creationTimeParamsImage =+    whoisUserParamsImage =       case params of-        [_, _, time, _] -> string defAttr (prettyUnixTime (Text.unpack time))+        [_, nick, user, host, _, real] ->+          text' (withStyle defAttr bold) nick <>+          text' (view palLabel pal) "!" <>+          parseIrcText' False user <>+          text' (view palLabel pal) "@" <>+          parseIrcText' False host <>+          label " gecos" <>+          parseIrcText' False real         _ -> rawParamsImage      whoisIdleParamsImage =       case params of-        [_, name, idle, signon, _txt] ->-          text' defAttr name <>-          text' defAttr " idle: " <>-          string defAttr (prettySeconds (Text.unpack idle)) <>-          text' defAttr " sign-on: " <>+        [_, _, idle, signon, _txt] ->+          string defAttr (prettyTime 1 (Text.unpack idle)) <>+          label " sign-on" <>           string defAttr (prettyUnixTime (Text.unpack signon))+        _ -> rawParamsImage +    whoisServerParamsImage =+      case params of+        [_, _, host, txt] ->+          parseIrcText' False host <>+          label " note" <>+          parseIrcText' False txt         _ -> rawParamsImage +    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+        _ -> rawParamsImage+ -- | Transform string representing seconds in POSIX time to pretty format. prettyUnixTime :: String -> String prettyUnixTime str =@@ -553,16 +608,18 @@     Just t  -> formatTime defaultTimeLocale "%A %B %e, %Y %H:%M:%S %Z" (t :: UTCTime)  -- | Render string representing seconds into days, hours, minutes, and seconds.-prettySeconds :: String -> String-prettySeconds str =+prettyTime :: Int -> String -> String+prettyTime scale str =   case readMaybe str of     Nothing -> str+    Just 0  -> "0s"     Just n  -> intercalate " "              $ map (\(u,i) -> show i ++ [u])-             $ dropWhile (\x -> snd x == 0)+             $ filter (\x -> snd x /= 0)              $ zip "dhms" [d,h,m,s :: Int]       where-        (n1,s) = quotRem n  60+        n0     = n * scale+        (n1,s) = quotRem n0 60         (n2,m) = quotRem n1 60         (d ,h) = quotRem n2 24 

@@ -34,6 +34,9 @@   , palCommandError   , palWindowDivider   , palLineMarker+  , palCModes+  , palUModes+  , palSnomask    , paletteMap @@ -45,6 +48,8 @@ import           Data.Text (Text) import           Data.Vector (Vector) import           Graphics.Vty.Attributes+import           Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap  -- | Color palette used for rendering the client UI data Palette = Palette@@ -68,6 +73,9 @@   , _palCommandPlaceholder :: Attr -- ^ command argument placeholder   , _palWindowDivider :: Attr -- ^ Divider between split windows   , _palLineMarker    :: Attr -- ^ Divider between new and old messages+  , _palCModes        :: HashMap Char Attr -- ^ channel mode attributes+  , _palUModes        :: HashMap Char Attr -- ^ user mode attributes+  , _palSnomask       :: HashMap Char Attr -- ^ snotice mask attributes   }   deriving Show @@ -96,6 +104,9 @@   , _palCommandPlaceholder      = withStyle defAttr reverseVideo   , _palWindowDivider           = withStyle defAttr reverseVideo   , _palLineMarker              = defAttr+  , _palCModes                  = HashMap.empty+  , _palUModes                  = HashMap.empty+  , _palSnomask                 = HashMap.empty   }  -- | Default nick highlighting colors that look nice in my dark solarized

@@ -28,6 +28,7 @@ import           Data.Foldable (for_) import qualified Data.Map.Strict as Map import           Data.Maybe+import           Data.HashMap.Strict (HashMap) import           Data.Text (Text) import qualified Data.Text as Text import           Graphics.Vty.Attributes@@ -283,14 +284,27 @@         Nothing -> Vty.emptyImage         Just cs -> Vty.string (view palSigil pal) myChanModes            Vty.<|> Vty.text' defAttr (idText nick)-           Vty.<|> parens defAttr (Vty.string defAttr ('+' : view csModes cs))+           Vty.<|> parens defAttr+                     (unpackImage $+                      modesImage (view palUModes pal) (view csModes cs) <>+                      snomaskImage)           where-            nick      = view csNick cs+            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+    modeImage m =+      char (fromMaybe defAttr (view (at m) pal)) m  subfocusImage :: ClientState -> Image' subfocusImage st = foldMap infoBubble (viewSubfocusLabel pal subfocus)@@ -333,29 +347,29 @@ channelModesImage :: Text -> Identifier -> ClientState -> Image' channelModesImage network channel st =   case preview (clientConnection network . csChannels . ix channel . chanModes) st of-    Just modeMap | not (null modeMap) ->-        string defAttr (" +" ++ modes) <>-        mconcat [ char defAttr ' ' <> text' defAttr arg | arg <- args, not (Text.null arg) ]-      where (modes,args) = unzip (Map.toList modeMap)-    _ -> mempty+    Just modeMap | not (null modeMap) -> " " <> modesImage (view palCModes pal) (Map.keys modeMap)+    _                                 -> mempty+  where+    pal = clientPalette st  viewSubfocusLabel :: Palette -> Subfocus -> Maybe Image' viewSubfocusLabel pal subfocus =   case subfocus of-    FocusMessages -> Nothing+    FocusMessages     -> Nothing     FocusWindows filt -> Just $ string (view palLabel pal) "windows" <>                                 opt (windowFilterName filt)-    FocusInfo     -> Just $ string (view palLabel pal) "info"-    FocusUsers    -> Just $ string (view palLabel pal) "users"-    FocusMentions -> Just $ string (view palLabel pal) "mentions"-    FocusPalette  -> Just $ string (view palLabel pal) "palette"-    FocusDigraphs -> Just $ string (view palLabel pal) "digraphs"-    FocusKeyMap   -> Just $ string (view palLabel pal) "keymap"-    FocusHelp mb  -> Just $ string (view palLabel pal) "help" <>-                            opt mb-    FocusIgnoreList -> Just $ string (view palLabel pal) "ignores"-    FocusRtsStats -> Just $ string (view palLabel pal) "rtsstats"-    FocusMasks m  -> Just $ mconcat+    FocusInfo         -> Just $ string (view palLabel pal) "info"+    FocusUsers        -> Just $ string (view palLabel pal) "users"+    FocusMentions     -> Just $ string (view palLabel pal) "mentions"+    FocusDCC          -> Just $ string (view palLabel pal) "dcc"+    FocusPalette      -> Just $ string (view palLabel pal) "palette"+    FocusDigraphs     -> Just $ string (view palLabel pal) "digraphs"+    FocusKeyMap       -> Just $ string (view palLabel pal) "keymap"+    FocusHelp mb      -> Just $ string (view palLabel pal) "help" <> opt mb+    FocusIgnoreList   -> Just $ string (view palLabel pal) "ignores"+    FocusRtsStats     -> Just $ string (view palLabel pal) "rtsstats"+    FocusCert{}       -> Just $ string (view palLabel pal) "cert"+    FocusMasks m      -> Just $ mconcat       [ string (view palLabel pal) "masks"       , char defAttr ':'       , char (view palLabel pal) m

@@ -29,7 +29,6 @@ import           Client.State.Focus import qualified Client.State.EditBox as Edit import           Control.Lens-import           Data.Char import qualified Data.HashSet as HashSet import           Data.HashSet (HashSet) import           Data.List@@ -47,11 +46,12 @@   where   macros = views (clientConfig . configMacros) (fmap macroSpec) st   (txt, content) =-     views (clientTextBox . Edit.content) (renderContent st myNick nicks macros pal) st+     renderContent st myNick nicks macros pal+       (view (clientTextBox . Edit.content) st)    lineImage = unpackImage (beginning <> content <> ending) -  leftOfCurWidth = myWcswidth ('^':txt)+  leftOfCurWidth = 1 + txt    croppedImage = Vty.resizeWidth width                $ Vty.cropLeft (Vty.imageWidth lineImage - newOffset) lineImage@@ -96,8 +96,8 @@   Recognizer MacroSpec {- ^ macro completions                     -} ->   Palette              {- ^ palette                               -} ->   Edit.Content         {- ^ content                               -} ->-  (String, Image')     {- ^ plain text rendering, image rendering -}-renderContent st myNick nicks macros pal c = (txt, wholeImg)+  (Int, Image')        {- ^ left-of-cursor width, image rendering -}+renderContent st myNick nicks macros pal c = (leftLen, wholeImg)   where   as  = reverse (view Edit.above c)   bs  = view Edit.below c@@ -107,28 +107,17 @@   leftCur = take (view Edit.pos cur) (view Edit.text cur)    -- ["one","two"] "three" --> "two one three"-  txt = foldl (\acc x -> x ++ ' ' : acc) leftCur as+  leftLen = length leftCur + length leftImgs + sum (map imageWidth leftImgs)    rndr = renderLine st pal myNick nicks macros +  leftImgs = map (rndr False) as+   wholeImg = mconcat            $ intersperse (plainText "\n")-           $ map (rndr False) as+           $ leftImgs           ++ rndr True curTxt            : map (rndr False) bs----- | Version of 'wcwidth' that accounts for how control characters are--- rendered-myWcwidth :: Char -> Int-myWcwidth x-  | isControl x = 1-  | otherwise   = Vty.wcwidth x---- | Version of 'wcswidth' that accounts for how control characters are--- rendered-myWcswidth :: String -> Int-myWcswidth = sum . map myWcwidth   -- | Render the active text box line using command highlighting and

@@ -39,6 +39,7 @@ import           Irc.Identifier import           Irc.UserInfo import           Irc.Codes+import           Client.State.DCC (isSend)  data MessageBody   = IrcBody    !IrcMsg@@ -63,6 +64,7 @@   | ReplySummary {-# UNPACK #-} !ReplyCode   | ChatSummary {-# UNPACK #-} !UserInfo   | CtcpSummary {-# UNPACK #-} !Identifier+  | DccSendSummary {-# UNPACK #-} !Identifier   | ChngSummary {-# UNPACK #-} !Identifier -- ^ Chghost command   | AcctSummary {-# UNPACK #-} !Identifier -- ^ Account command   | NoSummary@@ -92,6 +94,7 @@     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

@@ -1,5 +1,5 @@ {-# Options_GHC -Wno-unused-do-bind #-}-+{-# Language OverloadedStrings #-} {-| Module      : Client.Network.Async Description : Event-based network IO@@ -24,10 +24,10 @@  module Client.Network.Async   ( NetworkConnection-  , NetworkId   , NetworkEvent(..)   , createConnection   , Client.Network.Async.send+  , Client.Network.Async.recv    -- * Abort connections   , abortConnection@@ -46,31 +46,35 @@ import qualified Data.ByteString as B import           Data.Foldable import           Data.Time+import           Data.List import           Irc.RateLimit import           Hookup+import           Data.Text (Text)+import qualified Data.Text as Text+import           Data.Word (Word8)+import           Numeric (showHex)+import           OpenSSL.X509 (printX509)  --- | Identifier used to match connection events to connections.-type NetworkId = Int- -- | Handle for a network connection data NetworkConnection = NetworkConnection-  { connOutQueue :: !(TQueue ByteString)-  , connAsync    :: !(Async ())+  { connOutQueue :: TQueue ByteString+  , connInQueue  :: TQueue NetworkEvent+  , connAsync    :: Async ()   }  -- | The sum of incoming events from a network connection. All events -- are annotated with a network ID matching that given when the connection -- was created as well as the time at which the message was recieved. data NetworkEvent-  -- | Event for successful connection to host-  = NetworkOpen  !NetworkId !ZonedTime+  -- | Event for successful connection to host (certificate lines)+  = NetworkOpen  !ZonedTime [Text]   -- | Event for a new recieved line (newline removed)-  | NetworkLine  !NetworkId !ZonedTime !ByteString+  | NetworkLine  !ZonedTime !ByteString   -- | Final message indicating the network connection failed-  | NetworkError !NetworkId !ZonedTime !SomeException+  | NetworkError !ZonedTime !SomeException   -- | Final message indicating the network connection finished-  | NetworkClose !NetworkId !ZonedTime+  | NetworkClose !ZonedTime  instance Show NetworkConnection where   showsPrec p _ = showParen (p > 10)@@ -81,12 +85,20 @@   = PingTimeout      -- ^ sent when ping timer expires   | ForcedDisconnect -- ^ sent when client commands force disconnect   | StsUpgrade       -- ^ sent when the client disconnects due to sts policy+  | BadCertFingerprint ByteString (Maybe ByteString)+  | BadPubkeyFingerprint ByteString (Maybe ByteString)   deriving Show  instance Exception TerminationReason where   displayException PingTimeout      = "connection killed due to ping timeout"   displayException ForcedDisconnect = "connection killed by client command"   displayException StsUpgrade       = "connection killed by sts policy"+  displayException (BadCertFingerprint expect got) =+       "Expected certificate fingerprint: " ++ formatDigest expect +++       "; got: "    ++ maybe "none" formatDigest got+  displayException (BadPubkeyFingerprint expect got) =+       "Expected public key fingerprint: " ++ formatDigest expect +++       "; got: "    ++ maybe "none" formatDigest got  -- | Schedule a message to be transmitted on the network connection. -- These messages are sent unmodified. The message should contain a@@ -94,6 +106,9 @@ send :: NetworkConnection -> ByteString -> IO () send c msg = atomically (writeTQueue (connOutQueue c) msg) +recv :: NetworkConnection -> STM [NetworkEvent]+recv = flushTQueue . connInQueue+ -- | Force the given connection to terminate. abortConnection :: TerminationReason -> NetworkConnection -> IO () abortConnection reason c = cancelWith (connAsync c) reason@@ -104,17 +119,26 @@ -- early termination of the connection. createConnection ::   Int {- ^ delay in seconds -} ->-  NetworkId {- ^ Identifier to be used on incoming events -} ->   ServerSettings ->-  TQueue NetworkEvent {- Queue for incoming events -} ->   IO NetworkConnection-createConnection delay network settings inQueue =-   do outQueue <- atomically newTQueue+createConnection delay settings =+   do outQueue <- newTQueueIO+      inQueue  <- newTQueueIO        supervisor <- async $                       threadDelay (delay * 1000000) >>-                      startConnection network settings inQueue outQueue+                      startConnection settings inQueue outQueue +      let recordFailure :: SomeException -> IO ()+          recordFailure ex =+              do now <- getZonedTime+                 atomically (writeTQueue inQueue (NetworkError now ex))++          recordNormalExit :: IO ()+          recordNormalExit =+            do now <- getZonedTime+               atomically (writeTQueue inQueue (NetworkClose now))+       -- Having this reporting thread separate from the supervisor ensures       -- that canceling the supervisor with abortConnection doesn't interfere       -- with carefully reporting the outcome@@ -125,34 +149,29 @@        return NetworkConnection         { connOutQueue = outQueue+        , connInQueue  = inQueue         , connAsync    = supervisor         }-  where-    recordFailure :: SomeException -> IO ()-    recordFailure ex =-        do now <- getZonedTime-           atomically (writeTQueue inQueue (NetworkError network now ex)) -    recordNormalExit :: IO ()-    recordNormalExit =-      do now <- getZonedTime-         atomically (writeTQueue inQueue (NetworkClose network now)) - startConnection ::-  NetworkId ->   ServerSettings ->   TQueue NetworkEvent ->   TQueue ByteString ->   IO ()-startConnection network settings inQueue outQueue =+startConnection settings inQueue outQueue =   do rate <- newRateLimit                (view ssFloodPenalty settings)                (view ssFloodThreshold settings)      withConnection settings $ \h ->-       do reportNetworkOpen network inQueue+       do for_ (view ssTlsCertFingerprint settings)+            (checkCertFingerprint h)+          for_ (view ssTlsPubkeyFingerprint settings)+            (checkPubkeyFingerprint h)++          reportNetworkOpen h inQueue           withAsync (sendLoop h outQueue rate) $ \sender ->-            withAsync (receiveLoop network h inQueue) $ \receiver ->+            withAsync (receiveLoop h inQueue) $ \receiver ->               do res <- waitEitherCatch sender receiver                  case res of                    Left  Right{}  -> fail "PANIC: sendLoop returned"@@ -160,11 +179,47 @@                    Left  (Left e) -> throwIO e                    Right (Left e) -> throwIO e -reportNetworkOpen :: NetworkId -> TQueue NetworkEvent -> IO ()-reportNetworkOpen network inQueue =+checkCertFingerprint :: Connection -> Fingerprint -> IO ()+checkCertFingerprint h fp =+  do (expect, got) <-+       case fp of+         FingerprintSha1   expect -> (,) expect <$> getPeerCertFingerprintSha1   h+         FingerprintSha256 expect -> (,) expect <$> getPeerCertFingerprintSha256 h+         FingerprintSha512 expect -> (,) expect <$> getPeerCertFingerprintSha512 h+     unless (Just expect == got)+       (throwIO (BadCertFingerprint expect got))++checkPubkeyFingerprint :: Connection -> Fingerprint -> IO ()+checkPubkeyFingerprint h fp =+  do (expect, got) <-+       case fp of+         FingerprintSha1   expect -> (,) expect <$> getPeerPubkeyFingerprintSha1   h+         FingerprintSha256 expect -> (,) expect <$> getPeerPubkeyFingerprintSha256 h+         FingerprintSha512 expect -> (,) expect <$> getPeerPubkeyFingerprintSha512 h+     unless (Just expect == got)+       (throwIO (BadPubkeyFingerprint expect got))++reportNetworkOpen :: Connection -> TQueue NetworkEvent -> IO ()+reportNetworkOpen h inQueue =   do now <- getZonedTime-     atomically (writeTQueue inQueue (NetworkOpen network now))+     mbX509 <- getPeerCertificate h+     txts <- case mbX509 of+               Nothing -> return []+               Just x509 -> do str <- printX509 x509+                               return $! reverse (Text.lines (Text.pack str))+     atomically (writeTQueue inQueue (NetworkOpen now txts)) +formatDigest :: ByteString -> String+formatDigest+  = intercalate ":"+  . map showByte+  . B.unpack++showByte :: Word8 -> String+showByte x+  | x < 0x10  = '0' : showHex x ""+  | otherwise = showHex x ""+ sendLoop :: Connection -> TQueue ByteString -> RateLimit -> IO () sendLoop h outQueue rate =   forever $@@ -175,12 +230,12 @@ ircMaxMessageLength :: Int ircMaxMessageLength = 512 -receiveLoop :: NetworkId -> Connection -> TQueue NetworkEvent -> IO ()-receiveLoop network h inQueue =+receiveLoop :: Connection -> TQueue NetworkEvent -> IO ()+receiveLoop h inQueue =   do mb <- recvLine h (2*ircMaxMessageLength)      for_ mb $ \msg ->        do unless (B.null msg) $ -- RFC says to ignore empty messages             do now <- getZonedTime                atomically $ writeTQueue inQueue-                          $ NetworkLine network now msg-          receiveLoop network h inQueue+                          $ NetworkLine now msg+          receiveLoop h inQueue

@@ -20,6 +20,8 @@   , clientTextBox   , clientTextBoxOffset   , clientConnections+  , clientDCC+  , clientDCCUpdates   , clientWidth   , clientHeight   , clientEvents@@ -32,7 +34,6 @@   , clientActivityBar   , clientShowPing   , clientSubfocus-  , clientNetworkMap   , clientIgnores   , clientIgnoreMask   , clientConnection@@ -63,6 +64,7 @@   , addConnection   , removeNetwork   , clientTick+  , queueDCCTransfer   , applyMessageToClientState   , clientHighlights   , clientWindowNames@@ -76,6 +78,7 @@   -- * Add messages to buffers   , recordChannelMessage   , recordNetworkMessage+  , recordError   , recordIrcMessage    -- * Focus manipulation@@ -120,6 +123,7 @@ import           Client.State.Focus import           Client.State.Network import           Client.State.Window+import           Client.State.DCC import           Control.Applicative import           Control.Concurrent.MVar import           Control.Concurrent.STM@@ -152,6 +156,7 @@ import           Text.Regex.TDFA import           Text.Regex.TDFA.String (compile) + -- | All state information for the IRC client data ClientState = ClientState   { _clientWindows           :: !(Map Focus Window) -- ^ client message buffers@@ -161,9 +166,10 @@   , _clientSubfocus          :: !Subfocus           -- ^ current view mode   , _clientExtraFocus        :: ![Focus]            -- ^ extra messages windows to view -  , _clientConnections       :: !(IntMap NetworkState) -- ^ state of active connections+  , _clientConnections       :: !(HashMap Text NetworkState) -- ^ state of active connections   , _clientEvents            :: !(TQueue NetworkEvent)    -- ^ incoming network event queue-  , _clientNetworkMap        :: !(HashMap Text NetworkId) -- ^ network name to connection ID+  , _clientDCC               :: !DCCState                 -- ^ DCC subsystem+  , _clientDCCUpdates        :: !(TChan DCCUpdate)        -- ^ DCC update events    , _clientConfig            :: !Configuration            -- ^ client configuration   , _clientConfigPath        :: !FilePath                 -- ^ client configuration file path@@ -222,10 +228,7 @@   Applicative f =>   Text {- ^ network -} ->   LensLike' f ClientState NetworkState-clientConnection network f st =-  case view (clientNetworkMap . at network) st of-    Nothing -> pure st-    Just i  -> clientConnections (ix i f) st+clientConnection network = clientConnections . ix network  -- | The full top-most line that would be executed clientFirstLine :: ClientState -> String@@ -241,15 +244,17 @@    withExtensionState $ \exts -> -  do events <- atomically newTQueue-     sts    <- readPolicyFile+  do events    <- atomically newTQueue+     dccEvents <- atomically newTChan+     sts       <- readPolicyFile      let ignoreIds = map mkId (view configIgnores cfg)      k ClientState         { _clientWindows           = _Empty # ()-        , _clientNetworkMap        = _Empty # ()         , _clientIgnores           = HashSet.fromList ignoreIds         , _clientIgnoreMask        = buildMask ignoreIds         , _clientConnections       = _Empty # ()+        , _clientDCC               = emptyDCCState+        , _clientDCCUpdates        = dccEvents         , _clientTextBox           = Edit.defaultEditBox         , _clientTextBoxOffset     = 0         , _clientWidth             = 80@@ -297,7 +302,7 @@     Just cs -> do -- cancel the network thread                   abortConnection ForcedDisconnect (view csSocket cs)                   -- unassociate this network name from this network id-                  return $! over clientNetworkMap (sans network) st+                  return $! over clientConnections (sans network) st   -- | Add a message to the window associated with a given channel@@ -514,6 +519,18 @@      cfg        = view clientConfig st +recordError ::+  ZonedTime       {- ^ now             -} ->+  Text            {- ^ network         -} ->+  Text            {- ^ error message   -} ->+  ClientState     {- ^ client state    -} ->+  ClientState+recordError now net msg =+  recordNetworkMessage ClientMessage+    { _msgTime    = now+    , _msgNetwork = net+    , _msgBody    = ErrorBody msg+    }  -- | Record window line at the given focus creating the window if necessary recordWindowLine ::@@ -661,7 +678,7 @@   compile     defaultCompOpt     defaultExecOpt{captureGroups=False}-    "https?://([[:alnum:]-]+\\.)*([[:alnum:]-]+)(:[[:digit:]]+)?(/[^[:cntrl:][:space:]]*)|\+    "https?://([[:alnum:]-]+\\.)*([[:alnum:]-]+)(:[[:digit:]]+)?(/[-0-9a-zA-Z$_.+!*'(),%?=:@/;]*)?|\     \<https?://[^>]*>|\     \\\(https?://[^\\)]*\\)" @@ -685,18 +702,11 @@ -- | Remove a network connection and unlink it from the network map. -- This operation assumes that the network connection exists and should -- only be applied once per connection.-removeNetwork :: NetworkId -> ClientState -> (NetworkState, ClientState)-removeNetwork networkId st =-  case (clientConnections . at networkId <<.~ Nothing) st of+removeNetwork :: Text -> ClientState -> (NetworkState, ClientState)+removeNetwork network st =+  case (clientConnections . at network <<.~ Nothing) st of     (Nothing, _  ) -> error "removeNetwork: network not found"-    (Just cs, st1) ->-      -- Only remove the network mapping if it hasn't already been replaced-      -- with a new one. This can happen during reconnect in particular.-      let network = view csNetwork cs in-      forOf (clientNetworkMap . at network) st1 $ \mb ->-        case mb of-          Just i | i == networkId -> (cs,Nothing)-          _                       -> (cs,mb)+    (Just cs, st1) -> (cs, st1)  -- | Start a new connection. The delay is used for reconnections. addConnection ::@@ -732,45 +742,48 @@              Nothing   -> settings  -         i = nextAvailableKey (view clientConnections st)-          -- don't bother delaying on the first reconnect          delay = 15 * max 0 (attempts - 1)       c <- createConnection             delay-            i             settings1-            (view clientEvents st) -     let cs = newNetworkState i network settings1 c (PingConnecting attempts lastTime)+     let cs = newNetworkState network settings1 c (PingConnecting attempts lastTime)      traverse_ (sendMsg cs) (initialMessages cs) -     return $ set (clientNetworkMap . at network) (Just i)-            $ set (clientConnections . at i) (Just cs) st+     return $ set (clientConnections . at network) (Just cs) st --- | Find the first unused key in the intmap starting at 0.-nextAvailableKey :: IntMap a -> Int-nextAvailableKey m = foldr aux id (IntMap.keys m) 0-  where-    aux k next i-      | k == i    = next (i+1)-      | otherwise = i  applyMessageToClientState ::   ZonedTime                  {- ^ timestamp                -} ->   IrcMsg                     {- ^ message received         -} ->-  NetworkId                  {- ^ message network          -} ->+  Text                       {- ^ network name             -} ->   NetworkState               {- ^ network connection state -} ->   ClientState                {- ^ client state             -} ->-  ([RawIrcMsg], ClientState) {- ^ response , updated state -}-applyMessageToClientState time irc networkId cs st =-  cs' `seq` (reply, st')+  ([RawIrcMsg], Maybe DCCUpdate, ClientState) {- ^ response , DCC updates, updated state -}+applyMessageToClientState time irc network cs st =+  cs' `seq` (reply, dccUp, st')   where     (reply, cs') = applyMessage time irc cs-    network      = view csNetwork cs-    st'          = applyWindowRenames network irc-                 $ set (clientConnections . ix networkId) cs' st+    (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)+  -- | 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.

@@ -0,0 +1,357 @@+{-# 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           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, Family(..)+                                , 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+              { cpFamily = AF_INET+              , 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

@@ -71,7 +71,7 @@                       Nothing -> 0              let st1 = st & clientExtensions . esActive . at i ?~ ae-            (st2, h) <- clientPark i st1 $ \ptr -> startExtension ptr config ae+            (st2, h) <- clientPark i st1 (startExtension (clientToken st1) config ae)              -- save handle back into active extension             return $! st2 & clientExtensions . esActive . ix i %~ \ae' ->@@ -88,7 +88,7 @@      ifoldlM step st1 aes   where     step i st2 ae =-      do (st3,_) <- clientPark i st2 $ \ptr -> deactivateExtension ptr ae+      do (st3,_) <- clientPark i st2 (deactivateExtension ae)          return st3  @@ -115,7 +115,7 @@   IO (ClientState, Bool)  {- ^ new state and allow         -} chat1 _    st [] = return (st, True) chat1 chat st ((i,ae):aes) =-  do (st1, allow) <- clientPark i st $ \ptr -> chatExtension ptr ae chat+  do (st1, allow) <- clientPark i st (chatExtension ae chat)      if allow then chat1 chat st1 aes               else return (st1, False) @@ -142,7 +142,7 @@   IO (ClientState, Bool)  {- ^ new state and allow         -} message1 _    st [] = return (st, True) message1 chat st ((i,ae):aes) =-  do (st1, allow) <- clientPark i st $ \ptr -> notifyExtension ptr ae chat+  do (st1, allow) <- clientPark i st (notifyExtension ae chat)      if allow then message1 chat st1 aes               else return (st1, False) @@ -159,8 +159,7 @@             (IntMap.toList (view (clientExtensions . esActive) st)) of         Nothing -> return Nothing         Just (i,ae) ->-          do (st', _) <- clientPark i st $ \ptr ->-                            commandExtension ptr command ae+          do (st', _) <- clientPark i st (commandExtension command ae)              return (Just st')  @@ -168,16 +167,18 @@ clientPark ::   Int              {- ^ extension ID                                        -} ->   ClientState      {- ^ client state                                        -} ->-  (Ptr () -> IO a) {- ^ continuation using the stable pointer to the client -} ->+  IO a             {- ^ continuation using the stable pointer to the client -} ->   IO (ClientState, a) clientPark i st k =   do let mvar = view (clientExtensions . esMVar) st      putMVar mvar (i,st)-     let token = views (clientExtensions . esStablePtr) castStablePtrToPtr st-     res     <- k token+     res     <- k      (_,st') <- takeMVar mvar      return (st', res) +-- | Get the pointer used by C extensions to reenter the client.+clientToken :: ClientState -> Ptr ()+clientToken = views (clientExtensions . esStablePtr) castStablePtrToPtr  -- | Run the next available timer event on a particular extension. clientExtTimer ::@@ -190,6 +191,5 @@        Nothing -> return st        Just (_, timerId, fun, dat, ae') ->          do let st1 = set (clientExtensions . esActive . ix i) ae' st-            (st2,_) <- clientPark i st1 $ \ptr ->-                         runTimerCallback fun ptr (aeSession ae) dat timerId+            (st2,_) <- clientPark i st1 (runTimerCallback fun dat timerId)             return st2

@@ -45,6 +45,7 @@   = FocusMessages    -- ^ Show messages   | FocusInfo        -- ^ Show channel metadata   | FocusUsers       -- ^ Show channel user list+  | FocusDCC         -- ^ Show DCC offers list   | FocusMasks !Char -- ^ Show channel mask list for given mode   | FocusWindows WindowsFilter -- ^ Show client windows   | FocusPalette     -- ^ Show current palette@@ -53,7 +54,8 @@   | FocusKeyMap      -- ^ Show key bindings   | FocusHelp (Maybe Text) -- ^ Show help window with optional command   | FocusRtsStats    -- ^ Show GHC RTS statistics-  | FocusIgnoreList    -- ^ Show ignored masks+  | FocusIgnoreList  -- ^ Show ignored masks+  | FocusCert        -- ^ Show rendered certificate   deriving (Eq,Show)  -- | Unfocused first, followed by focuses sorted by network.

@@ -31,18 +31,19 @@   , csChannelTypes   , csTransaction   , csModes+  , csSnomask   , csStatusMsg   , csSettings   , csUserInfo   , csUsers   , csUser   , csModeCount-  , csNetworkId   , csNetwork   , csNextPingTime   , csPingStatus   , csLatency   , csLastReceived+  , csCertificate   , csMessageHooks   , csAuthenticationState @@ -110,14 +111,14 @@  -- | State tracked for each IRC connection data NetworkState = NetworkState-  { _csNetworkId    :: !NetworkId -- ^ network connection identifier-  , _csChannels     :: !(HashMap Identifier ChannelState) -- ^ joined channels+  { _csChannels     :: !(HashMap Identifier ChannelState) -- ^ joined channels   , _csSocket       :: !NetworkConnection -- ^ network socket   , _csModeTypes    :: !ModeTypes -- ^ channel mode meanings   , _csUmodeTypes   :: !ModeTypes -- ^ user mode meanings   , _csChannelTypes :: ![Char] -- ^ channel identifier prefixes   , _csTransaction  :: !Transaction -- ^ state for multi-message sequences   , _csModes        :: ![Char] -- ^ modes for the connected user+  , _csSnomask      :: ![Char] -- ^ server notice modes for the connected user   , _csStatusMsg    :: ![Char] -- ^ modes that prefix statusmsg channel names   , _csSettings     :: !ServerSettings -- ^ settings used for this connection   , _csUserInfo     :: !UserInfo -- ^ usermask used by the server for this connection@@ -132,6 +133,7 @@   , _csLatency      :: !(Maybe NominalDiffTime) -- ^ latency calculated from previous pong   , _csPingStatus   :: !PingStatus      -- ^ state of ping timer   , _csLastReceived :: !(Maybe UTCTime) -- ^ time of last message received+  , _csCertificate  :: ![Text]   }   deriving Show @@ -249,15 +251,13 @@ -- | Construct a new network state using the given settings and -- default values as specified by the IRC specification. newNetworkState ::-  NetworkId         {- ^ unique network ID         -} ->   Text              {- ^ network name              -} ->   ServerSettings    {- ^ server settings           -} ->   NetworkConnection {- ^ active network connection -} ->   PingStatus        {- ^ initial ping status       -} ->   NetworkState      {- ^ new network state         -}-newNetworkState networkId network settings sock ping = NetworkState-  { _csNetworkId    = networkId-  , _csUserInfo     = UserInfo "*" "" ""+newNetworkState network settings sock ping = NetworkState+  { _csUserInfo     = UserInfo "*" "" ""   , _csChannels     = HashMap.empty   , _csSocket       = sock   , _csChannelTypes = defaultChannelTypes@@ -265,6 +265,7 @@   , _csUmodeTypes   = defaultUmodeTypes   , _csTransaction  = CapTransaction   , _csModes        = ""+  , _csSnomask      = ""   , _csStatusMsg    = ""   , _csSettings     = settings   , _csModeCount    = 3@@ -276,6 +277,7 @@   , _csLatency      = Nothing   , _csNextPingTime = Nothing   , _csLastReceived = Nothing+  , _csCertificate  = []   }  @@ -417,6 +419,13 @@                $ set csModes "" ns -- reset modes         _ -> ns +    RPL_SNOMASK ->+      case args of+        _me:snomask0:_+          | Just snomask <- Text.stripPrefix "+" snomask0 ->+           set csSnomask (Text.unpack snomask)+        _             -> id+     RPL_NOTOPIC ->       case args of         _me:chan:_ -> overChannel@@ -583,6 +592,7 @@     RPL_ENDOFQUIETLIST  -> True     RPL_CHANNELMODEIS   -> True     RPL_UMODEIS         -> True+    RPL_SNOMASK         -> True     RPL_WHOREPLY        -> True     RPL_ENDOFWHO        -> True     RPL_WHOSPCRPL       -> True

@@ -16,8 +16,10 @@ import           Client.Image.PackedImage import           Client.State import           Client.State.Focus+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@@ -44,13 +46,15 @@     (ChannelFocus network channel, FocusMasks mode) ->       maskListImages mode network channel w st     (_, FocusWindows filt) -> windowsImages filt st-    (_, FocusMentions) -> mentionsViewLines w st-    (_, FocusPalette) -> paletteViewLines pal-    (_, FocusDigraphs) -> digraphLines w st-    (_, FocusKeyMap) -> keyMapLines st-    (_, FocusHelp mb) -> helpImageLines st mb pal-    (_, FocusRtsStats) -> rtsStatsLines (view clientRtsStats st) pal-    (_, FocusIgnoreList) -> ignoreListLines (view clientIgnores st) pal+    (_, FocusDCC)          -> dccImages st+    (_, FocusMentions)     -> mentionsViewLines w st+    (_, FocusPalette)      -> paletteViewLines pal+    (_, FocusDigraphs)     -> digraphLines w st+    (_, FocusKeyMap)       -> keyMapLines st+    (_, FocusHelp mb)      -> helpImageLines st mb pal+    (_, FocusRtsStats)     -> rtsStatsLines (view clientRtsStats st) pal+    (_, FocusIgnoreList)   -> ignoreListLines (view clientIgnores st) pal+    (_, FocusCert)         -> certViewLines st     _ -> chatMessageImages focus w st   where     pal = clientPalette st

@@ -0,0 +1,43 @@+{-# Language OverloadedStrings #-}++{-|+Module      : Client.View.Cert+Description : Network certificate renderer+Copyright   : (c) Eric Mertens, 2019+License     : ISC+Maintainer  : emertens@gmail.com++-}+module Client.View.Cert+  ( certViewLines+  ) where++import           Client.Image.PackedImage+import           Client.Image.Palette+import           Client.State+import           Client.State.Focus+import           Client.State.Network+import           Control.Lens+import           Data.Text (Text)+import           Graphics.Vty.Attributes++-- | Render the lines used in a channel mask list+certViewLines ::+  ClientState -> [Image']+certViewLines st+  | Just network <- currentNetwork st+  , Just cs <- preview (clientConnection network) st+  , let xs = view csCertificate cs+  , not (null xs)+  = text' defAttr <$> xs++  | otherwise = [text' (view palError pal) "No certificate available"]+  where+    pal = clientPalette st++currentNetwork :: ClientState -> Maybe Text+currentNetwork st =+  case view clientFocus st of+    NetworkFocus net   -> Just net+    ChannelFocus net _ -> Just net+    Unfocused          -> Nothing

@@ -29,6 +29,8 @@ import           Data.Time import           Graphics.Vty.Attributes import           Irc.Identifier+import qualified Data.Map as Map+import qualified Data.Text as Text  -- | Render the lines used in a channel mask list channelInfoImages ::@@ -47,10 +49,13 @@  channelInfoImages' :: Palette -> HashSet Identifier -> ChannelState -> [Image'] channelInfoImages' pal myNicks !channel-    = topicLine+    = reverse+    $ topicLine     : provenanceLines    ++ creationLines    ++ urlLines+   ++ modeLines+   ++ modeArgLines    where     label = text' (view palLabel pal)@@ -80,3 +85,12 @@           Nothing -> []           Just url -> [ label "Channel URL: " <> parseIrcText url ] +    modeLines = [label "Modes: " <> string defAttr modes | not (null modes) ]+      where+        modes = views chanModes Map.keys channel++    modeArgLines =+      [ string (view palLabel pal) ("Mode " ++ [mode, ':', ' ']) <> parseIrcText arg+        | (mode, arg) <- Map.toList (view chanModes channel)+        , not (Text.null arg)+        ]

@@ -0,0 +1,68 @@+{-# 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

@@ -171,4 +171,5 @@ metadataWindowLine st wl =   case view wlSummary wl of     ChatSummary who -> (ignoreImage, userNick who, Nothing) <$ guard (identIgnored who st)+    DccSendSummary _ -> Nothing -- Show a custom WindowLine latter     summary         -> metadataImg summary

@@ -23,12 +23,7 @@ import           Data.List.Split (chunksOf) import           Graphics.Vty.Attributes import qualified Data.Vector as Vector--digits :: String-digits = "0123456789ABCDEF"--digitImage :: Char -> Image'-digitImage d = string defAttr [' ', d, ' ']+import           Numeric (showHex)  columns :: [Image'] -> Image' columns = mconcat . intersperse (char defAttr ' ')@@ -63,50 +58,63 @@    ++   [ ""-  , "Available terminal palette colors: 0x<row><col>"+  , "Available terminal palette colors (hex)"   , ""-  , columns (map digitImage (' ':digits))-  , columns isoColors ]+  ] +++  terminalColorTable -  +++terminalColorTable :: [Image']+terminalColorTable =+  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]+     : [] -  [ columns-  $ digitImage digit-  : [ string (withBackColor defAttr c) "   "-    | col <- [0 .. 15]-    , let c = Color240 (row * 16 + col)-    ]-  | (digit,row) <- zip (drop 1 digits) [0 ..]+colorBox :: Int -> [Image']+colorBox start =+  [ "   " <>+     columns+      [ mconcat+          [ colorBlock showPadHex k (Color240 (fromIntegral (k - 16)))+          | k <- [j, j+6 .. j + 30 ] ]+      | j <- [i, i + 0x24, i + 0x48 ]+      ]+  | i <- [ start .. start + 5 ]   ]  isLight :: Color -> Bool-isLight (ISOColor c) = c `elem` [1, 3, 5, 6, 7]+isLight (ISOColor c) = c `elem` [7, 10, 11, 14, 15] isLight (Color240 c) =   case color240CodeToRGB c of     Just (r, g, b) -> (r `max` g `max` b) > 200     Nothing        -> True  -isoColors :: [Image']-isoColors =-  digitImage '0'-  : [ string (withBackColor defAttr (ISOColor c)) "   "-    | c <- [0..15]-    ]+isoColors :: Image'+isoColors = "   " <> foldMap (\c -> colorBlock showPadHex c (ISOColor (fromIntegral c))) [0 .. 15]  colorTable :: [Image'] colorTable   = map (\imgs -> mconcat ("   " : imgs))-  $ chunksOf 8 [ render i (mircColors Vector.! i) | i <- [0 .. 15] ]+  $ chunksOf 8 [ colorBlock showPadDec i (mircColors Vector.! i) | i <- [0 .. 15] ]   ++ [[]]-  ++ chunksOf 12 [ render i (mircColors Vector.! i) | i <- [16 .. 98] ]-  where-    showPad i-      | i < 10    = '0' : show i-      | otherwise = show i+  ++ chunksOf 12 [ colorBlock showPadDec i (mircColors Vector.! i) | i <- [16 .. 98] ] -    render i c =-      string (withForeColor (withBackColor defAttr c) (if isLight c then black else white)) (' ' : showPad i ++ " ")+colorBlock :: (Int -> String) -> Int -> Color -> Image'+colorBlock showNum i c =+  string (withForeColor (withBackColor defAttr c) (if isLight c then black else white)) (showNum i)++showPadDec :: Int -> String+showPadDec i+  | i < 10    = ' ' : '0' : shows i " "+  | otherwise = ' ' :       shows i " "++showPadHex :: Int -> String+showPadHex i+  | i < 16    = ' ' : '0' : showHex i " "+  | otherwise = ' ' :       showHex i " "  paletteEntries :: Palette -> [Image'] paletteEntries pal =

@@ -78,6 +78,7 @@     NickSummary who _ -> Just who     ChatSummary who   -> Just (userNick who)     CtcpSummary who   -> Just who+    DccSendSummary who -> Just who     AcctSummary who   -> Just who     ChngSummary who   -> Just who     ReplySummary {}   -> Nothing