diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 ` - Send the given params to the named extension * `/exec [-n network] [-c channel] ` - Execute a command, If no network or channel are provided send output to client window, if network and channel are provided send output as messages, if network is provided send output as raw IRC messages. * `/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 diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: glirc -version: 2.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, diff --git a/include/glirc-api.h b/include/glirc-api.h --- a/include/glirc-api.h +++ b/include/glirc-api.h @@ -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 **); diff --git a/src/Client/CApi.hs b/src/Client/CApi.hs --- a/src/Client/CApi.hs +++ b/src/Client/CApi.hs @@ -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. diff --git a/src/Client/CApi/Exports.hs b/src/Client/CApi/Exports.hs --- a/src/Client/CApi/Exports.hs +++ b/src/Client/CApi/Exports.hs @@ -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) diff --git a/src/Client/CApi/Types.hsc b/src/Client/CApi/Types.hsc --- a/src/Client/CApi/Types.hsc +++ b/src/Client/CApi/Types.hsc @@ -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 () diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -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) diff --git a/src/Client/Commands/Arguments/Spec.hs b/src/Client/Commands/Arguments/Spec.hs --- a/src/Client/Commands/Arguments/Spec.hs +++ b/src/Client/Commands/Arguments/Spec.hs @@ -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 -} -> diff --git a/src/Client/Commands/Exec.hs b/src/Client/Commands/Exec.hs --- a/src/Client/Commands/Exec.hs +++ b/src/Client/Commands/Exec.hs @@ -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 diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -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 diff --git a/src/Client/Configuration/ServerSettings.hs b/src/Client/Configuration/ServerSettings.hs --- a/src/Client/Configuration/ServerSettings.hs +++ b/src/Client/Configuration/ServerSettings.hs @@ -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 diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -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 diff --git a/src/Client/EventLoop/Network.hs b/src/Client/EventLoop/Network.hs new file mode 100644 --- /dev/null +++ b/src/Client/EventLoop/Network.hs @@ -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 diff --git a/src/Client/Hook/FreRelay.hs b/src/Client/Hook/FreRelay.hs new file mode 100644 --- /dev/null +++ b/src/Client/Hook/FreRelay.hs @@ -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 diff --git a/src/Client/Hook/Snotice.hs b/src/Client/Hook/Snotice.hs --- a/src/Client/Hook/Snotice.hs +++ b/src/Client/Hook/Snotice.hs @@ -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|])] +-- -} diff --git a/src/Client/Hooks.hs b/src/Client/Hooks.hs --- a/src/Client/Hooks.hs +++ b/src/Client/Hooks.hs @@ -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) ] diff --git a/src/Client/Image/Message.hs b/src/Client/Image/Message.hs --- a/src/Client/Image/Message.hs +++ b/src/Client/Image/Message.hs @@ -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 diff --git a/src/Client/Image/Palette.hs b/src/Client/Image/Palette.hs --- a/src/Client/Image/Palette.hs +++ b/src/Client/Image/Palette.hs @@ -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 diff --git a/src/Client/Image/StatusLine.hs b/src/Client/Image/StatusLine.hs --- a/src/Client/Image/StatusLine.hs +++ b/src/Client/Image/StatusLine.hs @@ -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 diff --git a/src/Client/Image/Textbox.hs b/src/Client/Image/Textbox.hs --- a/src/Client/Image/Textbox.hs +++ b/src/Client/Image/Textbox.hs @@ -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 diff --git a/src/Client/Message.hs b/src/Client/Message.hs --- a/src/Client/Message.hs +++ b/src/Client/Message.hs @@ -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 diff --git a/src/Client/Network/Async.hs b/src/Client/Network/Async.hs --- a/src/Client/Network/Async.hs +++ b/src/Client/Network/Async.hs @@ -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 diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -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?://[^\\)]*\\)" @@ -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. diff --git a/src/Client/State/DCC.hs b/src/Client/State/DCC.hs new file mode 100644 --- /dev/null +++ b/src/Client/State/DCC.hs @@ -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 diff --git a/src/Client/State/Extensions.hs b/src/Client/State/Extensions.hs --- a/src/Client/State/Extensions.hs +++ b/src/Client/State/Extensions.hs @@ -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 diff --git a/src/Client/State/Focus.hs b/src/Client/State/Focus.hs --- a/src/Client/State/Focus.hs +++ b/src/Client/State/Focus.hs @@ -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. diff --git a/src/Client/State/Network.hs b/src/Client/State/Network.hs --- a/src/Client/State/Network.hs +++ b/src/Client/State/Network.hs @@ -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 diff --git a/src/Client/View.hs b/src/Client/View.hs --- a/src/Client/View.hs +++ b/src/Client/View.hs @@ -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 diff --git a/src/Client/View/Cert.hs b/src/Client/View/Cert.hs new file mode 100644 --- /dev/null +++ b/src/Client/View/Cert.hs @@ -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 diff --git a/src/Client/View/ChannelInfo.hs b/src/Client/View/ChannelInfo.hs --- a/src/Client/View/ChannelInfo.hs +++ b/src/Client/View/ChannelInfo.hs @@ -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) + ] diff --git a/src/Client/View/DCCList.hs b/src/Client/View/DCCList.hs new file mode 100644 --- /dev/null +++ b/src/Client/View/DCCList.hs @@ -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 diff --git a/src/Client/View/Messages.hs b/src/Client/View/Messages.hs --- a/src/Client/View/Messages.hs +++ b/src/Client/View/Messages.hs @@ -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 diff --git a/src/Client/View/Palette.hs b/src/Client/View/Palette.hs --- a/src/Client/View/Palette.hs +++ b/src/Client/View/Palette.hs @@ -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" + , "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 = diff --git a/src/Client/View/UrlSelection.hs b/src/Client/View/UrlSelection.hs --- a/src/Client/View/UrlSelection.hs +++ b/src/Client/View/UrlSelection.hs @@ -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