diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -7,20 +7,77 @@ Unreleased ========== +0.3.0 +========== + +* [#176](https://github.com/serokell/xrefcheck/pull/176) + + Enabled `autolink` extension for `cmark-gfm`, so now we're finding strings + like `www.google.com` or `https://google.com`, treating them as links + and checking. +* [#175](https://github.com/serokell/xrefcheck/pull/175) + + Reorganize top-level config keys. +* [#178](https://github.com/serokell/xrefcheck/pull/178) + + Rename exclusion-related config options. +* [#183](https://github.com/serokell/xrefcheck/pull/183) + + Add support for image links. +* [#199](https://github.com/serokell/xrefcheck/pull/199) + + Now annotation + `` instead of `` + should be used to disable checking for links in file, so it's clearer that + file itself is not ignored (and links can target it). +* [#215](https://github.com/serokell/xrefcheck/pull/215) + + Now we notify user when there are scannable files that were not added to Git + yet. Also added CLI option `--include-untracked` to scan such files and treat + as existing. +* [#191](https://github.com/serokell/xrefcheck/pull/191) + + Now we consider slash `/` (and only it) as path separator in local links for all OS, + so xrefcheck's report is OS-independent + + Use utf-8 compatible codepage on Windows +* [#224](https://github.com/serokell/xrefcheck/pull/224) + + Now the program output does not contain unicode characters that are not widely supported. +* [#229](https://github.com/serokell/xrefcheck/pull/229) + + Now we call references to anchors in current file (e.g. `[a](#b)`) as + `file-local` references instead of calling them `current file` (which was ambiguous). +* [#233](https://github.com/serokell/xrefcheck/pull/233) + + Now xrefcheck does not follow redirect links by default. It fails for permanent + redirect responses (i.e. 301 and 308) and passes for temporary ones (i.e. 302, 303, 307). +* [#231](https://github.com/serokell/xrefcheck/pull/231) + + Anchor analysis takes now into account the appropriate case-sensitivity depending on + the configured Markdown flavour. +* [#254](https://github.com/serokell/xrefcheck/pull/254) + + Now the `dump-config` command does not overwrite a file unless explicitly told with a + `--force` flag. Also, a `--stdout` flag allows to print the config to stdout instead. +* [#250](https://github.com/serokell/xrefcheck/pull/250) + + Now the redirect behavior for external references can be modified via rules in the + configuration file with the `externalRefRedirects` parameter. +* [#261](https://github.com/serokell/xrefcheck/pull/261) + + Symlinks are now not processed by the scanner. +* [#268](https://github.com/serokell/xrefcheck/pull/268) + + Added CLI option `--color` that enables ANSI colors in output. + + Changed the output coloring defaults to show colors when `CI` env variable is `true`. +* [#271](https://github.com/serokell/xrefcheck/pull/271) + + Now Xrefcheck is able to follow relative redirects. +* [#262](https://github.com/serokell/xrefcheck/pull/262) + + Now Xrefcheck includes a scanner that verifies the repository symlinks. +* [#307](https://github.com/serokell/xrefcheck/pull/307) + + The output of Xrefcheck is now more legible. + + Add the `--print-unix-paths` (`-u`) flag to print paths in Unix style (with + forward slashes) on all platforms. + 0.2.2 ========== * [#145](https://github.com/serokell/xrefcheck/pull/145) + Add check that there is no unknown fields in config. * [#158](https://github.com/serokell/xrefcheck/pull/158) - + Fixed bug when we reported footnotes as broken links + + Fixed bug when we reported footnotes as broken links. * [#163](https://github.com/serokell/xrefcheck/pull/163) + Fixed an issue where the progress bar thread might be unexpectedly cancelled and jumble up the output. * [#184](https://github.com/serokell/xrefcheck/pull/184) + Make `flavor` a required parameter. * [#182](https://github.com/serokell/xrefcheck/pull/182) + Now we call references to anchors in current file (e.g. `[a](#b)`) as - `current file` references instead of calling them `local` (which was ambigious). + `current file` references instead of calling them `local` (which was ambiguous). * [#188](https://github.com/serokell/xrefcheck/pull/188) + Added CLI option `--no-colors` that disables ANSI colors in output. + Automatically disable coloring if it is not supported @@ -57,7 +114,7 @@ + Make possible to specify whether ignore localhost links, use `check-localhost` CLA argument (by default localhost links will not be checked). + Make possible to ignore auth failures (assume 'protected' links - valid), use `ignoreAuthFailures` parameter of config. + valid), use `ignoreAuthFailures` parameter of config. * [#66](https://github.com/serokell/xrefcheck/pull/66) + Added support for ftp links. * [#74](https://github.com/serokell/xrefcheck/pull/83) @@ -106,10 +163,10 @@ + Switch to lts-17.3. * [#53](https://github.com/serokell/xrefcheck/pull/53) + Make possible to include a regular expression in - `ignoreRefs` parameter of config to ignore external - references. + `ignoreRefs` parameter of config to ignore external + references. + Add support of right in-place ignoring annotations - such as `ignore file`, `ignore paragraph` and `ignore link`. + such as `ignore file`, `ignore paragraph` and `ignore link`. 0.1.2 ======= diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,46 +6,46 @@ # Xrefcheck -[![Build status](https://badge.buildkite.com/75461331a6058b334383cdfca1071dc1f908b70cf069d857b7.svg?branch=master)](https://buildkite.com/serokell/xrefcheck) +![Build status](https://github.com/serokell/xrefcheck/actions/workflows/ci.yml/badge.svg) + -Xrefcheck is a tool for verifying local and external references in repository documentation that is quick, easy to setup, and suitable to be added to CI. +Xrefcheck is a tool for verifying local and external references in a repository's documentation that is quick, easy to setup, and suitable to be run on a CI pipeline. -Output sample +Output sample -### Motivation +## Motivation [↑](#xrefcheck) -As the project evolves, links in documentation have a tendency to get broken. This is usually because of: -1. File movements; -2. Markdown header renames; -3. Outer sites ceasing their existence. +As a project evolves, links in markdown documentation have a tendency to become broken. This is usually because: +1. A file has been moved; +2. A markdown header has been renamed; +3. An external site has ceased to exist. This tool will help you to keep references in order. +You can run `xrefcheck` continuously in your CI pipeline, +and it will let you know when it finds a broken link. -### Aims +## Aims [↑](#xrefcheck) Comparing to alternative solutions, this tool tries to achieve the following points: -* Quickness - local references are verified instantly even for moderately-sized repositories. -* Easy setup - no extra actions required, just run the tool in the repository root. -Both relative and absolute local links are supported out of the box. +* Quickness + * References are verified in parallel. + * References with the same target URI are only verified once. + * It first attempts to verify external links with a `HEAD` request; only when that fails does it try a `GET` request. +* Resilience + * When you have many links to the same domain, the service is likely to start replying with "429 Too Many Requests". + When this happens, `xrefcheck` will wait the requested amount of seconds before retrying. +* Easy setup - no extra actions required, just run `xrefcheck` in the repository root. * Conservative verifier allows using this tool in CI, no false positives (e.g. on sites which require authentication) should be reported. -### A comparison with other solutions - -* [linky](https://github.com/mattias-p/linky) - a well-configurable verifier written in Rust, scans one specified file at a time and works good in pair with system utilities like `find`. - This tool requires some configuring before it can be applied to a repository or added to CI. -* [awesome_bot](https://github.com/dkhamsing/awesome_bot) - a solution written in Ruby that can be easily included in CI or integrated into GitHub. - Its features include duplicated URLs detection, specifying allowed HTTP error codes and reporting generation. - At the moment of writing, it scans only external references and checking anchors is not possible. -* [remark-validate-links](https://github.com/remarkjs/remark-validate-links) and [remark-lint-no-dead-urls](https://github.com/davidtheclark/remark-lint-no-dead-urls) - highly configurable Javascript solution for checking local and remote links resp. - It is able to check multiple repositores at once if they are gathered in one folder. - Being written on JavaScript, it is fairly slow on large repositories. -* [markdown-link-check](https://github.com/tcort/markdown-link-check) - another checker written in JavaScript, scans one specific file at a time. - Supports `mailto:` link resolution. -* [url-checker](https://github.com/paramt/url-checker) - GitHub action which checks links in specified files. -* [linkcheck](https://github.com/filiph/linkcheck) - advanced site crawler, checks for `HTML` files. There are other solutions for this particular task which we don't mention here. +## Features [↑](#xrefcheck) -At the moment of writing, the listed solutions don't support ftp/ftps links. +* Supports both GitHub and GitLab flavored markdown. +* Supports Windows and Unix systems. +* Supports relative and absolute local links. +* Supports external links (`http`, `https`, `ftp` and `ftps`). +* Detects broken and ambiguous anchors in local links. +* Integration with GitHub Actions. ## Dependencies [↑](#xrefcheck) @@ -55,23 +55,36 @@ We provide the following ways for you to use xrefcheck: -- [GitHub action](https://github.com/marketplace/actions/xrefcheck) -- [statically linked binaries](https://github.com/serokell/xrefcheck/releases) +- [GitHub Actions](https://github.com/marketplace/actions/xrefcheck) +- [Statically linked binaries](https://github.com/serokell/xrefcheck/releases), e. g. on Linux: + ``` + mkdir -p bin/ + wget --quiet -O bin/xrefcheck https://serokell.gateway.scarf.sh/xrefcheck/latest/xrefcheck-x86_64-linux + chmod +x bin/xrefcheck + bin/xrefcheck + ``` - [Docker image](https://hub.docker.com/r/serokell/xrefcheck) -- [building from source](#build-instructions-) + ``` + docker pull serokell.docker.scarf.sh/serokell/xrefcheck + ``` +- [Building from source](#build-instructions-) +- Nix + ``` + nix shell -f https://github.com/serokell/xrefcheck/archive/master.tar.gz -c xrefcheck + ``` If none of those are suitable for you, please open an issue! -To find all broken links in a repository, run from within its folder: +To find all broken links in a repository, simply run `xrefcheck` from its root folder: ```sh xrefcheck ``` -To also display all found links and anchors: +To also display a list of all links and anchors: ```sh -xrefcheck -v +xrefcheck --verbose ``` For description of other options: @@ -80,112 +93,121 @@ xrefcheck --help ``` - -### Special functionality - -
- Ignoring external links - - If you want some external links to not be verified, you can use one of the following ways to ignore those links: - -1. Add the regular expression that matches the ignoring link to the `ignoreRefs` parameter of your config file. - - For example: - ```yaml - ignoreRefs: - - https://bad.reference.(org|com)(/?) - ``` - allows to ignore both `https://bad.reference.org` and `https://bad.reference.com` with or without last "/". - -2. Add right in-place annotation using one of the following ignoring modes (each mode is just a comment with a certain syntax). - - * Ignore the link: - - There are several ways to add this annotation: - - * Just add it like a regular text before the ignoring link. - - ```markdown - Bad ['com' reference](https://bad.reference.com) and bad ['org' reference](https://bad.reference.org) - ``` - - * Separate the ignoring link from the annotation and the following text with single new lines. +To configure `xrefcheck`, run: - ```markdown - Bad ['com' reference](https://bad.reference.com) and bad - ['org'](https://bad.reference.org) - reference - ``` +```sh +xrefcheck dump-config --type GitHub +``` - Therefore only `https://bad.reference.org` will be ignored. +This will create a `.xrefcheck.yaml` file with all the configuration +options, [here's an example](tests/configs/github-config.yaml). +This file should be committed to your repository. - * If the ignoring link is the first in a paragraph, then the annotation can also be added before a paragraph. +## Build instructions [↑](#xrefcheck) - ```markdown - - [Bad 'org' reference](https://bad.reference.org) - [Bad 'com' reference](https://bad.reference.com) - ``` +Run `stack install` to build everything and install the executable. +If you wish to use `cabal`, you need to run [`stack2cabal`](https://hackage.haskell.org/package/stack2cabal) first! - It is still the same `https://bad.reference.org` will be ignored in this case. +### Run on Windows [↑](#xrefcheck) - * Ignore the paragraph: +On Windows, executable requires some dynamic libraries (DLLs). +They are shipped together with executable in [releases page](https://github.com/serokell/xrefcheck/releases). +If you have built executable from source using `stack install`, +those DLLs are downloaded by stack to a location that is not on `%PATH%` by default. +There are several ways to fix this: +- Add `%LocalAppData%\Programs\stack\x86_64-windows\msys2-<...>\mingw64\bin` to your PATH +- run `stack exec xrefcheck.exe -- ` instead of `xrefcheck.exe ` +- add DLLs from archive from releases page to a folder containing `xrefcheck.exe` - ```markdown - - Bad ['org' reference](https://bad.reference.org) - Bad ['com' reference](https://bad.reference.com) +## FAQ [↑](#xrefcheck) - Bad ['io' reference](https://bad.reference.io) - ``` +1. How do I ignore specific files? + * To ignore a specific file, you can either use the `--ignore ` command-line option, + or the `ignore` list in the config file. Links _to_ those files will be reported as errors, links _from_ those files will not be verified. - In this way, `https://bad.reference.org` and `https://bad.reference.com` will be ignored and `https://bad.reference.io` will still be verified. +1. How do I ignore specific links? + * Add an entry to the `ignoreLocalRefsTo` or `ignoreExternalRefsTo` lists in the config file. + * Alternatively, add a `` annotation before the link: + ```md + + Link to some [invalid resource](https://fictitious.uri/). + ``` + ```md + A [valid link](https://www.google.com) + followed by an [invalid link](https://fictitious.uri/). + ``` + * You can also use a `` annotation to ignore all links in a paragraph. - * Ignore the whole file: - ```markdown - - +1. How do I ignore all links from a specific markdown file? + * Add a glob pattern to the `ignoreRefsFrom` list in the config file. + * Or add a `` at the top of the file. - - ...the rest of the file... - ``` +1. How do I ignore all external links? + * If you wish to ignore all http/ftp links, you can use `--mode local-only`. - Using this you can ignore the whole file. -
+1. How does `xrefcheck` handle links that require authentication? + * It's common for projects to contain links to protected resources. + By default, when `xrefcheck` attempts to verify a link and is faced with a `403 Forbidden` or a `401 Unauthorized`, it assumes the link is valid. + * This behavior can be disabled by setting `ignoreAuthFailures: false` in the config file. -## Configuring +1. How does `xrefcheck` handle redirects? + * The rules from the default configuration are as follows: + * Permanent redirects (i.e. 301 and 308) are reported as errors. + * There are no rules for other redirects, except for a special GitLab case, so they are assumed to be valid. + * Redirect rules can be specified with the `externalRefRedirects` parameter within `networking`, which accepts an array of + rules with keys `from`, `to`, `on` and `outcome`. The rule applied is the first one that matches with + the `from`, `to` and `on` fields, if any, where + * `from` is a regular expression, as in `ignoreExternalRefsTo`, for the source link in a single redirection step. Its absence means that + every link matches. + * `to` is a regular expression for the target link in a single redirection step. Its absence also means that every link matches. + * `on` accepts `temporary`, `permanent` or a specific redirect HTTP code. Its absence also means that + every response code matches. + * The `outcome` parameter accepts `valid`, `invalid` or `follow`. The last one follows the redirect by applying the + same configuration rules. -Configuration template (with all options explained) can be dumped with: + For example, this configuration forbids 307 redirects to a specific domain and makes redirections from HTTP to HTTPS to be followed: -```sh -xrefcheck dump-config -t GitHub -``` + ``` + externalRefRedirects: + - to: "https?://forbidden.com.*" + on: 307 + outcome: invalid + - from: "http://.*" + to: "https://.*" + outcome: follow + ``` -Currently supported options include: -* Timeout for checking external references; -* List of ignored files. + The first one applies if both of them match. -## Build instructions [↑](#xrefcheck) + * The number of redirects allowed in a single redirect chain is limited and can be configured with the + `maxRedirectFollows` parameter, also within `networking`. A number smaller than 0 disables the limit. -Run `stack install` to build everything and install the executable. -If you want to use cabal, you need to run (`stack2cabal`)[https://hackage.haskell.org/package/stack2cabal] first! +1. How does `xrefcheck` handle localhost links? + * By default, `xrefcheck` will ignore links to localhost. + * This behavior can be disabled by removing the corresponding entry from the `ignoreExternalRefsTo` list in the config file. -### CI and nix [↑](#xrefcheck) +## Further work [↑](#xrefcheck) -To build only the executables, run `nix-build`. You can use this line on your CI to use xrefcheck: -``` -nix run -f https://github.com/serokell/xrefcheck/archive/master.tar.gz -c xrefcheck -``` +- [ ] Support link detection in different languages, not only Markdown. + - [ ] Haskell Haddock is first in turn. -Our CI uses `nix-build xrefcheck.nix` to build the whole project, including tests and Haddock. -It is based on the [`haskell.nix`](https://input-output-hk.github.io/haskell.nix/) project. -You can do that too if you wish. +## A comparison with other solutions [↑](#xrefcheck) -## For further work [↑](#xrefcheck) +* [linky](https://github.com/mattias-p/linky) - a well-configurable verifier written in Rust, scans one specified file at a time and works well with system utilities like `find`. + This tool requires some configuring before it can be applied to a repository or added to CI. +* [awesome_bot](https://github.com/dkhamsing/awesome_bot) - a solution written in Ruby that can be easily included in CI or integrated into GitHub. + Its features include duplicated URLs detection, specifying allowed HTTP error codes and reporting generation. + At the moment of writing, it scans only external references and checking anchors is not possible. +* [remark-validate-links](https://github.com/remarkjs/remark-validate-links) and [remark-lint-no-dead-urls](https://github.com/davidtheclark/remark-lint-no-dead-urls) - highly configurable JavaScript solution for checking local and external links respectively. + It is able to check multiple repositories at once if they are gathered in one folder. + Doesn't handle "429 Too Many Requests", so false positives are likely when you have many links to the same domain. +* [markdown-link-check](https://github.com/tcort/markdown-link-check) - another checker written in JavaScript, scans one specific file at a time. + Supports `mailto:` link resolution. +* [url-checker](https://github.com/paramt/url-checker) - GitHub Action which checks external links in specified files. + Does not check local links. +* [linkcheck](https://github.com/filiph/linkcheck) - advanced site crawler, verifies links in `HTML` files. There are other solutions for this particular task which we don't mention here. -- [ ] Support for non-Unix systems. -- [ ] Support link detection in different languages, not only Markdown. - - [ ] Haskell Haddock is first in turn. +At the moment of writing, the listed solutions don't support ftp/ftps links. ## Issue tracker [↑](#xrefcheck) diff --git a/exec/Main.hs b/exec/Main.hs --- a/exec/Main.hs +++ b/exec/Main.hs @@ -7,18 +7,24 @@ import Universum -import Data.ByteString qualified as BS import Main.Utf8 (withUtf8) +import System.IO.CodePage (withCP65001) -import Xrefcheck.CLI (Command (..), getCommand) +import System.Directory (doesFileExist) +import Xrefcheck.CLI (Command (..), DumpConfigMode (..), getCommand) import Xrefcheck.Command (defaultAction) import Xrefcheck.Config (defConfigText) main :: IO () -main = withUtf8 $ do +main = withUtf8 $ withCP65001 $ do command <- getCommand case command of DefaultCommand options -> defaultAction options - DumpConfig repoType path -> - BS.writeFile path (defConfigText repoType) + DumpConfig repoType (DCMFile forceFlag path) -> do + whenM ((not forceFlag &&) <$> doesFileExist path) do + putTextLn "Output file exists. Use --force to overwrite." + exitFailure + writeFile path (defConfigText repoType) + DumpConfig repoType DCMStdout -> + putStr (defConfigText repoType) diff --git a/ftp-tests/Test/Xrefcheck/FtpLinks.hs b/ftp-tests/Test/Xrefcheck/FtpLinks.hs --- a/ftp-tests/Test/Xrefcheck/FtpLinks.hs +++ b/ftp-tests/Test/Xrefcheck/FtpLinks.hs @@ -7,19 +7,19 @@ , test_FtpLinks ) where -import Universum +import Universum hiding ((.~)) -import Data.Tagged (Tagged, untag) +import Control.Lens ((.~)) +import Data.Tagged (untag) import Options.Applicative (help, long, strOption) import Test.Tasty (TestTree, askOption, testGroup) import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) import Test.Tasty.Options as Tasty (IsOption (..), OptionDescription (Option), safeRead) import Xrefcheck.Config - (Config' (cVerification), VerifyConfig, VerifyConfig' (vcIgnoreRefs), defConfig) import Xrefcheck.Core (Flavor (GitHub)) -import Xrefcheck.Verify - (VerifyError (..), VerifyResult (VerifyResult), checkExternalResource, verifyErrors) +import Xrefcheck.Scan (ecIgnoreExternalRefsToL) +import Xrefcheck.Verify (VerifyError (..), checkExternalResource) -- | A list with all the options needed to configure FTP links tests. ftpOptions :: [OptionDescription] @@ -37,49 +37,46 @@ optionHelp = "[Test.Xrefcheck.FtpLinks] FTP host without trailing slash" parseValue v = FtpHostOpt <$> safeRead v optionCLParser = FtpHostOpt <$> strOption - ( long (untag (optionName :: Tagged FtpHostOpt String)) - <> help (untag (optionHelp :: Tagged FtpHostOpt String)) + ( long (untag @FtpHostOpt optionName) + <> help (untag @FtpHostOpt optionHelp) ) - -config :: VerifyConfig -config = (cVerification $ defConfig GitHub) { vcIgnoreRefs = [] } +config :: Config +config = defConfig GitHub & cExclusionsL . ecIgnoreExternalRefsToL .~ [] test_FtpLinks :: TestTree test_FtpLinks = askOption $ \(FtpHostOpt host) -> do testGroup "Ftp links handler" [ testCase "handles correct link to file" $ do let link = host <> "/pub/file_exists.txt" - result <- checkExternalResource config link - result @?= VerifyResult [] + result <- runExceptT $ checkExternalResource emptyChain config link + result @?= Right () , testCase "handles empty link (host only)" $ do let link = host - result <- checkExternalResource config link - result @?= VerifyResult [] + result <- runExceptT $ checkExternalResource emptyChain config link + result @?= Right () , testCase "handles correct link to non empty directory" $ do let link = host <> "/pub/" - result <- checkExternalResource config link - result @?= VerifyResult [] + result <- runExceptT $ checkExternalResource emptyChain config link + result @?= Right () , testCase "handles correct link to empty directory" $ do let link = host <> "/empty/" - result <- checkExternalResource config link - result @?= VerifyResult [] + result <- runExceptT $ checkExternalResource emptyChain config link + result @?= Right () , testCase "throws exception when file not found" $ do let link = host <> "/pub/file_does_not_exists.txt" - result <- checkExternalResource config link - case verifyErrors result of - Nothing -> + result <- runExceptT $ checkExternalResource emptyChain config link + case result of + Right () -> assertFailure "No exception was raised, FtpEntryDoesNotExist expected" - Just errors -> - assertBool "Expected FtpEntryDoesNotExist, got other exceptions" - (any ( - \case + Left err -> + assertBool "Expected FtpEntryDoesNotExist, got other exceptions" $ + case err of FtpEntryDoesNotExist _ -> True ExternalFtpException _ -> True _ -> False - ) $ toList errors) ] diff --git a/src/Xrefcheck/CLI.hs b/src/Xrefcheck/CLI.hs --- a/src/Xrefcheck/CLI.hs +++ b/src/Xrefcheck/CLI.hs @@ -7,14 +7,16 @@ module Xrefcheck.CLI ( VerifyMode (..) - , shouldCheckLocal - , shouldCheckExternal + , ExclusionOptions (..) , Command (..) + , DumpConfigMode (..) , Options (..) - , VerifyOptions (..) - , addVerifyOptions - , TraversalOptions (..) - , addTraversalOptions + , NetworkingOptions (..) + + , addNetworkingOptions + , shouldCheckLocal + , shouldCheckExternal + , addExclusionOptions , defaultConfigPaths , getCommand ) where @@ -29,25 +31,28 @@ (Mod, OptionFields, Parser, ReadM, auto, command, eitherReader, execParser, flag, flag', footerDoc, fullDesc, help, helpDoc, helper, hsubparser, info, infoOption, long, metavar, option, progDesc, short, strOption, switch, value) -import Options.Applicative.Help.Pretty (Doc, displayS, fill, fillSep, indent, renderPretty, text) +import Options.Applicative.Help.Pretty (Doc, fill, fillSep, indent, pretty) import Options.Applicative.Help.Pretty qualified as Pretty +import Text.Interpolation.Nyan import Paths_xrefcheck (version) -import Xrefcheck.Config (VerifyConfig, VerifyConfig' (..)) +import Xrefcheck.Config (NetworkingConfig, NetworkingConfig' (..)) import Xrefcheck.Core import Xrefcheck.Scan -import Xrefcheck.System (RelGlobPattern, mkGlobPattern) -import Xrefcheck.Util (ColorMode (WithColors, WithoutColors), normaliseWithNoTrailing) +import Xrefcheck.System (CanonicalRelGlobPattern, PrintUnixPaths (..), mkCanonicalRelGlobPattern) +import Xrefcheck.Util (ColorMode (WithColors, WithoutColors)) modeReadM :: ReadM VerifyMode modeReadM = eitherReader $ \s -> case find (\mi -> miName mi == s) modes of Just mi -> Right $ miMode mi - Nothing -> Left . mconcat $ intersperse "\n" - [ "Unknown mode " <> show s <> "." - , "Allowed values: " <> mconcat (intersperse ", " $ map (show . miName) modes) - ] + Nothing -> Left + [int|| + Unknown mode #s{s}. + Allowed values: #{intercalate ", " $ map (show . miName) modes}. + |] + data ModeInfo = ModeInfo { miName :: String , miMode :: VerifyMode @@ -66,38 +71,44 @@ data Command = DefaultCommand Options - | DumpConfig Flavor FilePath + | DumpConfig Flavor DumpConfigMode +data DumpConfigMode + = DCMFile Bool FilePath + | DCMStdout + data Options = Options - { oConfigPath :: Maybe FilePath - , oRoot :: FilePath - , oMode :: VerifyMode - , oVerbose :: Bool - , oShowProgressBar :: Maybe Bool - , oColorMode :: ColorMode - , oTraversalOptions :: TraversalOptions - , oVerifyOptions :: VerifyOptions + { oConfigPath :: Maybe FilePath + , oRoot :: FilePath + , oMode :: VerifyMode + , oVerbose :: Bool + , oShowProgressBar :: Maybe Bool + , oColorMode :: Maybe ColorMode + , oPrintUnixPaths :: PrintUnixPaths + , oExclusionOptions :: ExclusionOptions + , oNetworkingOptions :: NetworkingOptions + , oScanPolicy :: ScanPolicy } -data TraversalOptions = TraversalOptions - { toIgnored :: [RelGlobPattern] +data ExclusionOptions = ExclusionOptions + { eoIgnore :: [CanonicalRelGlobPattern] } -addTraversalOptions :: TraversalConfig -> TraversalOptions -> TraversalConfig -addTraversalOptions TraversalConfig{..} (TraversalOptions ignored) = - TraversalConfig - { tcIgnored = tcIgnored ++ ignored +addExclusionOptions :: ExclusionConfig -> ExclusionOptions -> ExclusionConfig +addExclusionOptions ExclusionConfig{..} (ExclusionOptions ignore) = + ExclusionConfig + { ecIgnore = ecIgnore ++ ignore , .. } -data VerifyOptions = VerifyOptions - { voMaxRetries :: Maybe Int +data NetworkingOptions = NetworkingOptions + { noMaxRetries :: Maybe Int } -addVerifyOptions :: VerifyConfig -> VerifyOptions -> VerifyConfig -addVerifyOptions VerifyConfig{..} (VerifyOptions maxRetries) = - VerifyConfig - { vcMaxRetries = fromMaybe vcMaxRetries maxRetries +addNetworkingOptions :: NetworkingConfig -> NetworkingOptions -> NetworkingConfig +addNetworkingOptions NetworkingConfig{..} (NetworkingOptions maxRetries) = + NetworkingConfig + { ncMaxRetries = fromMaybe ncMaxRetries maxRetries , .. } @@ -113,10 +124,10 @@ type RepoType = Flavor filepathOption :: Mod OptionFields FilePath -> Parser FilePath -filepathOption = fmap normaliseWithNoTrailing <$> strOption +filepathOption = strOption -globOption :: Mod OptionFields RelGlobPattern -> Parser RelGlobPattern -globOption = option $ eitherReader $ mkGlobPattern +globOption :: Mod OptionFields CanonicalRelGlobPattern -> Parser CanonicalRelGlobPattern +globOption = option $ eitherReader mkCanonicalRelGlobPattern repoTypeReadM :: ReadM RepoType repoTypeReadM = eitherReader $ \name -> @@ -125,8 +136,10 @@ allRepoTypesNamed = allRepoTypes <&> \ty -> (toString $ T.toLower (show ty), ty) failureText name = - "Unknown repository type: " <> show name <> "\n\ - \Expected one of: " <> mconcat (intersperse ", " $ map show allRepoTypes) + [int|| + Unknown repository type: #s{name} + Expected one of: #{intercalate ", " $ map show allRepoTypes}. + |] allRepoTypes = allFlavors optionsParser :: Parser Options @@ -135,11 +148,13 @@ short 'c' <> long "config" <> metavar "FILEPATH" <> - help ("Path to configuration file. \ - \If not specified, tries to read config from one of " <> - (mconcat . intersperse ", " $ map show defaultConfigPaths) <> ". \ - \If none of these files exist, default configuration is used." - ) + help + [int|| + Path to configuration file. \ + If not specified, tries to read config from one of \ + #{intercalate ", " $ map show defaultConfigPaths}. \ + If none of these files exist, default configuration is used. + |] oRoot <- filepathOption $ short 'r' <> long "root" <> @@ -171,32 +186,49 @@ help "Do not display progress bar during verification." , pure Nothing ] - oColorMode <- flag WithColors WithoutColors $ - long "no-color" <> - help "Disable ANSI coloring of output" - oTraversalOptions <- traversalOptionsParser - oVerifyOptions <- verifyOptionsParser + oColorMode <- asum + [ flag' (Just WithColors) $ + long "color" <> + help "Enable ANSI coloring of output. \ + \When `CI` env var is set to true or the command output corresponds to a terminal, \ + \this option will be enabled by default." + , flag' (Just WithoutColors) $ + long "no-color" <> + help "Disable ANSI coloring of output." + , pure Nothing + ] + oPrintUnixPaths <- fmap PrintUnixPaths $ switch $ + short 'u' <> + long "--print-unix-paths" <> + help "Print paths in Unix style (with forward slashes) on all platforms." + oExclusionOptions <- exclusionOptionsParser + oNetworkingOptions <- networkingOptionsParser + oScanPolicy <- flag OnlyTracked IncludeUntracked $ + long "include-untracked" <> + help "Scan and treat as existing files that were not added to Git.\ + \ Files explicitly ignored by Git are always ignored by xrefcheck." return Options{..} -traversalOptionsParser :: Parser TraversalOptions -traversalOptionsParser = do - toIgnored <- many . globOption $ - long "ignored" <> - metavar "GLOB PATTERN" <> - help "Files which we pretend do not exist.\ +exclusionOptionsParser :: Parser ExclusionOptions +exclusionOptionsParser = do + eoIgnore <- many . globOption $ + long "ignore" <> + metavar "GLOB_PATTERN" <> + help "Ignore these files. References to them will fail verification,\ + \ and references from them will not be verified.\ \ Glob patterns that contain wildcards MUST be enclosed\ \ in quotes to avoid being expanded by shell." - return TraversalOptions{..} + return ExclusionOptions{..} -verifyOptionsParser :: Parser VerifyOptions -verifyOptionsParser = do - voMaxRetries <- option (Just <$> auto) $ +networkingOptionsParser :: Parser NetworkingOptions +networkingOptionsParser = do + noMaxRetries <- option (Just <$> auto) $ long "retries" <> metavar "INT" <> value Nothing <> help "How many attempts to retry an external link after getting \ \a \"429 Too Many Requests\" response." - return VerifyOptions{..} + return NetworkingOptions{..} dumpConfigOptions :: Parser Command dumpConfigOptions = hsubparser $ @@ -204,17 +236,35 @@ info parser $ progDesc "Dump default configuration into a file." where - parser = DumpConfig <$> repoTypeOption <*> outputOption - - allRepoTypes = "(" <> intercalate " | " (map (show @String) allFlavors) <> ")" + parser = DumpConfig <$> repoTypeOption <*> mode repoTypeOption = option repoTypeReadM $ short 't' <> long "type" <> - metavar "REPOSITORY TYPE" <> - help ("Git repository type. Can be " <> allRepoTypes <> ". Case insensitive.") + metavar "REPOSITORY_TYPE" <> + help [int|| + Git repository type. \ + Can be (#{intercalate " | " $ map show allFlavors}). \ + Case insensitive. + |] + mode = + stdoutMode <|> fileMode + + fileMode = + DCMFile <$> forceMode <*> outputOption + + stdoutMode = + flag' DCMStdout $ + long "stdout" <> + help "Write the config file to stdout." + + forceMode = + switch $ + long "force" <> + help "Overwrite the config file if it already exists." + outputOption = filepathOption $ short 'o' <> @@ -244,17 +294,13 @@ footerDoc (pure ignoreModesMsg) ignoreModesMsg :: Doc -ignoreModesMsg = text $ header <> body +ignoreModesMsg = text header <> body where header = "To ignore a link in your markdown, \ \include \"\"\n\ \comment with one of these modes:\n" - body = displayS (renderPretty pageParam pageWidth doc) "" - pageWidth = 80 - pageParam = 1 - - doc = fillSep $ map formatDesc modeDescr + body = fillSep $ map formatDesc modeDescr modeDescr = [ (" \"link\"", L.words "Ignore the link right after the comment.") @@ -269,3 +315,6 @@ formatDesc (mode, descr) = fill modeIndent (text mode) <> indent descrIndent (fillSep $ map text descr) + +text :: String -> Doc +text = pretty diff --git a/src/Xrefcheck/Command.hs b/src/Xrefcheck/Command.hs --- a/src/Xrefcheck/Command.hs +++ b/src/Xrefcheck/Command.hs @@ -9,32 +9,34 @@ import Universum -import Data.Reflection (give) +import Data.Reflection (Given, give) import Data.Yaml (decodeFileEither, prettyPrintParseException) -import Fmt (blockListF', build, fmt, fmtLn, indentF) +import Fmt (build, fmt, fmtLn) import System.Console.Pretty (supportsPretty) import System.Directory (doesFileExist) +import Text.Interpolation.Nyan -import Xrefcheck.CLI (Options (..), addTraversalOptions, addVerifyOptions, defaultConfigPaths) +import Xrefcheck.CLI (Options (..), addExclusionOptions, addNetworkingOptions, defaultConfigPaths) import Xrefcheck.Config - (Config, Config' (..), ScannersConfig (..), defConfig, normaliseConfigFilePaths, overrideConfig) + (Config, Config' (..), ScannersConfig, ScannersConfig' (..), defConfig, overrideConfig) import Xrefcheck.Core (Flavor (..)) import Xrefcheck.Progress (allowRewrite) import Xrefcheck.Scan - (FormatsSupport, ScanError (..), ScanResult (..), scanRepo, specificFormatsSupport) import Xrefcheck.Scanners.Markdown (markdownSupport) -import Xrefcheck.System (askWithinCI) +import Xrefcheck.Scanners.Symlink (symlinkSupport) +import Xrefcheck.System (PrintUnixPaths (..), askWithinCI) import Xrefcheck.Util -import Xrefcheck.Verify (verifyErrors, verifyRepo) +import Xrefcheck.Verify (reportVerifyErrs, verifyErrors, verifyRepo) readConfig :: FilePath -> IO Config -readConfig path = fmap (normaliseConfigFilePaths . overrideConfig) do +readConfig path = fmap overrideConfig do decodeFileEither path >>= either (error . toText . prettyPrintParseException) pure -formats :: ScannersConfig -> FormatsSupport -formats ScannersConfig{..} = specificFormatsSupport +configuredFileSupport :: Given PrintUnixPaths => ScannersConfig -> FileSupport +configuredFileSupport ScannersConfig{..} = firstFileSupport [ markdownSupport scMarkdown + , symlinkSupport ] findFirstExistingFile :: [FilePath] -> IO (Maybe FilePath) @@ -46,8 +48,14 @@ defaultAction :: Options -> IO () defaultAction Options{..} = do + withinCI <- askWithinCI coloringSupported <- supportsPretty - give (if coloringSupported then oColorMode else WithoutColors) $ do + let colorMode = oColorMode ?: + if withinCI || coloringSupported + then WithColors + else WithoutColors + + give oPrintUnixPaths $ give colorMode $ do config <- case oConfigPath of Just configPath -> readConfig configPath Nothing -> do @@ -56,40 +64,38 @@ Just configPath -> readConfig configPath Nothing -> do hPutStrLn @Text stderr - "Configuration file not found, using default config \ - \for GitHub repositories\n" + [int|| + Configuration file not found, using default config \ + for GitHub repositories + |] pure $ defConfig GitHub - withinCI <- askWithinCI let showProgressBar = oShowProgressBar ?: not withinCI (ScanResult scanErrs repoInfo) <- allowRewrite showProgressBar $ \rw -> do - let fullConfig = addTraversalOptions (cTraversal config) oTraversalOptions - scanRepo rw (formats $ cScanners config) fullConfig oRoot + let fullConfig = addExclusionOptions (cExclusions config) oExclusionOptions + fileSupport = configuredFileSupport $ cScanners config + scanRepo oScanPolicy rw fileSupport fullConfig oRoot when oVerbose $ - fmtLn $ "=== Repository data ===\n\n" <> indentF 2 (build repoInfo) + fmt [int|| + === Repository data === - unless (null scanErrs) . reportScanErrs $ sortBy (compare `on` seFile) scanErrs + #{interpolateIndentF 2 (build repoInfo)} + |] + whenJust (nonEmpty $ sortBy (compare `on` seFile) scanErrs) reportScanErrs + verifyRes <- allowRewrite showProgressBar $ \rw -> do - let fullConfig = addVerifyOptions (cVerification config) oVerifyOptions - verifyRepo rw fullConfig oMode oRoot repoInfo + let fullConfig = config + { cNetworking = addNetworkingOptions (cNetworking config) oNetworkingOptions } + verifyRepo rw fullConfig oMode repoInfo case verifyErrors verifyRes of - Nothing | null scanErrs -> fmtLn "All repository links are valid." + Nothing | null scanErrs -> + fmtLn $ colorIfNeeded Green "All repository links are valid." Nothing -> exitFailure - Just (toList -> verifyErrs) -> do - fmt "\n\n" + Just verifyErrs -> do + unless (null scanErrs) $ fmt "\n" reportVerifyErrs verifyErrs exitFailure - where - reportScanErrs errs = do - void . fmt $ "=== Scan errors found ===\n\n" <> - indentF 2 (blockListF' "➥ " build errs) - fmtLn $ "Scan errors dumped, " <> build (length errs) <> " in total." - - reportVerifyErrs errs = do - void . fmt $ "=== Invalid references found ===\n\n" <> - indentF 2 (blockListF' "➥ " build errs) - fmtLn $ "Invalid references dumped, " <> build (length errs) <> " in total." diff --git a/src/Xrefcheck/Config.hs b/src/Xrefcheck/Config.hs --- a/src/Xrefcheck/Config.hs +++ b/src/Xrefcheck/Config.hs @@ -5,32 +5,26 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module Xrefcheck.Config where - -import Universum.Unsafe qualified as Unsafe +module Xrefcheck.Config + ( module Xrefcheck.Config + , module Xrefcheck.Data.Redirect + , defConfigText + ) where -import Universum +import Universum hiding ((.~)) -import Control.Exception (assert) -import Control.Lens (makeLensesWith) +import Control.Lens (makeLensesWith, (.~)) import Data.Aeson (genericParseJSON) -import Data.ByteString qualified as BS -import Data.Map qualified as Map import Data.Yaml (FromJSON (..), decodeEither', prettyPrintParseException, withText) -import Instances.TH.Lift () -import Text.Regex.TDFA qualified as R -import Text.Regex.TDFA.ByteString () -import Text.Regex.TDFA.Common -import Text.Regex.TDFA.Text qualified as R - +import Text.Regex.TDFA.Text () import Time (KnownRatName, Second, Time (..), unitsP) import Xrefcheck.Config.Default import Xrefcheck.Core +import Xrefcheck.Data.Redirect import Xrefcheck.Scan import Xrefcheck.Scanners.Markdown -import Xrefcheck.System (RelGlobPattern, normaliseGlobPattern) -import Xrefcheck.Util (Field, aesonConfigOption, postfixFields, (-:)) +import Xrefcheck.Util (Field, aesonConfigOption, postfixFields) -- | Type alias for Config' with all required fields. type Config = Config' Identity @@ -40,199 +34,127 @@ -- | Overall config. data Config' f = Config - { cTraversal :: Field f (TraversalConfig' f) - , cVerification :: Field f (VerifyConfig' f) - , cScanners :: ScannersConfig + { cExclusions :: Field f (ExclusionConfig' f) + , cNetworking :: Field f (NetworkingConfig' f) + , cScanners :: ScannersConfig' f } deriving stock (Generic) -normaliseConfigFilePaths :: Config -> Config -normaliseConfigFilePaths Config{..} - = Config - { cTraversal = normaliseTraversalConfigFilePaths cTraversal - , cVerification = normaliseVerifyConfigFilePaths cVerification - , cScanners - } - --- | Type alias for VerifyConfig' with all required fields. -type VerifyConfig = VerifyConfig' Identity +-- | Type alias for NetworkingConfig' with all required fields. +type NetworkingConfig = NetworkingConfig' Identity --- | Config of verification. -data VerifyConfig' f = VerifyConfig - { vcAnchorSimilarityThreshold :: Field f Double - , vcExternalRefCheckTimeout :: Field f (Time Second) - , vcVirtualFiles :: Field f [RelGlobPattern] - -- ^ Files which we pretend do exist. - , vcNotScanned :: Field f [RelGlobPattern] - -- ^ Files, references in which we should not analyze. - , vcIgnoreRefs :: Field f [Regex] - -- ^ Regular expressions that match external references we should not verify. - , vcIgnoreAuthFailures :: Field f Bool +-- | Config of networking. +data NetworkingConfig' f = NetworkingConfig + { ncExternalRefCheckTimeout :: Field f (Time Second) + -- ^ When checking external references, how long to wait on request before + -- declaring "Response timeout". + , ncIgnoreAuthFailures :: Field f Bool -- ^ If True - links which return 403 or 401 code will be skipped, -- otherwise – will be marked as broken, because we can't check it. - , vcDefaultRetryAfter :: Field f (Time Second) + , ncDefaultRetryAfter :: Field f (Time Second) -- ^ Default Retry-After delay, applicable when we receive a 429 response -- and it does not contain a @Retry-After@ header. - , vcMaxRetries :: Field f Int + , ncMaxRetries :: Field f Int + -- ^ How many attempts to retry an external link after getting + -- a "429 Too Many Requests" response. + -- Timeouts may also be accounted here, see the description + -- of `maxTimeoutRetries` field. + -- + -- If a site once responded with 429 error code, subsequent + -- request timeouts will also be treated as hitting the site's + -- rate limiter and result in retry attempts, unless the + -- maximum retries number has been reached. + -- + -- On other errors xrefcheck fails immediately, without retrying. + , ncMaxTimeoutRetries :: Field f Int + -- ^ Querying a given domain that ever returned 429 before, + -- this defines how many timeouts are allowed during retries. + -- + -- For such domains, timeouts likely mean hitting the rate limiter, + -- and so xrefcheck considers timeouts in the same way as 429 errors. + -- + -- For other domains, a timeout results in a respective error, no retry + -- attempts will be performed. Use `externalRefCheckTimeout` option + -- to increase the time after which timeout is declared. + -- + -- This option is similar to `maxRetries`, the difference is that + -- this `maxTimeoutRetries` option limits only the number of retries + -- caused by timeouts, and `maxRetries` limits the number of retries + -- caused both by 429s and timeouts. + , ncMaxRedirectFollows :: Field f Int + -- ^ Maximum number of links that can be followed in a single redirect + -- chain. + , ncExternalRefRedirects :: Field f RedirectConfig + -- ^ Rules to override the redirect behavior for external references. } deriving stock (Generic) -normaliseVerifyConfigFilePaths :: VerifyConfig -> VerifyConfig -normaliseVerifyConfigFilePaths vc@VerifyConfig{ vcVirtualFiles, vcNotScanned} - = vc - { vcVirtualFiles = map normaliseGlobPattern vcVirtualFiles - , vcNotScanned = map normaliseGlobPattern vcNotScanned - } +-- | A list of custom redirect rules. +type RedirectConfig = [RedirectRule] +-- | Type alias for ScannersConfig' with all required fields. +type ScannersConfig = ScannersConfig' Identity + -- | Configs for all the supported scanners. -data ScannersConfig = ScannersConfig +data ScannersConfig' f = ScannersConfig { scMarkdown :: MarkdownConfig + , scAnchorSimilarityThreshold :: Field f Double + -- ^ On 'anchor not found' error, how much similar anchors should be displayed as + -- hint. Number should be between 0 and 1, larger value means stricter filter. } deriving stock (Generic) makeLensesWith postfixFields ''Config' -makeLensesWith postfixFields ''VerifyConfig' - --- | Picks raw config with @:PLACEHOLDER::@ and fills the specified fields --- in it, picking a replacement suitable for the given key. Only strings and lists --- of strings can be filled this way. --- --- This will fail if any placeholder is left unreplaced, however extra keys in --- the provided replacement won't cause any warnings or failures. -fillHoles - :: HasCallStack - => [(ByteString, Either ByteString [ByteString])] - -> ByteString - -> ByteString -fillHoles allReplacements rawConfig = - let holesLocs = R.getAllMatches $ holeLineRegex `R.match` rawConfig - in mconcat $ replaceHoles 0 holesLocs - where - showBs :: ByteString -> Text - showBs = show @_ @Text . decodeUtf8 - - holeLineRegex :: R.Regex - holeLineRegex = R.makeRegex ("[ -]+:PLACEHOLDER:[^:]+:" :: Text) - - replacementsMap = Map.fromList allReplacements - getReplacement key = - Map.lookup key replacementsMap - ?: error ("Replacement for key " <> showBs key <> " is not specified") - - pickConfigSubstring :: Int -> Int -> ByteString - pickConfigSubstring from len = BS.take len $ BS.drop from rawConfig - - replaceHoles :: Int -> [(R.MatchOffset, R.MatchLength)] -> [ByteString] - replaceHoles processedLen [] = one $ BS.drop processedLen rawConfig - replaceHoles processedLen ((off, len) : locs) = - -- in our case matches here should not overlap - assert (off > processedLen) $ - pickConfigSubstring processedLen (off - processedLen) : - replaceHole (pickConfigSubstring off len) ++ - replaceHoles (off + len) locs - - holeItemRegex :: R.Regex - holeItemRegex = R.makeRegex ("(^|:)([ ]*):PLACEHOLDER:([^:]+):" :: Text) - - holeListRegex :: R.Regex - holeListRegex = R.makeRegex ("^([ ]*-[ ]*):PLACEHOLDER:([^:]+):" :: Text) - - replaceHole :: ByteString -> [ByteString] - replaceHole holeLine = if - | Just [_wholeMatch, _beginning, leadingSpaces, key] <- - R.getAllTextSubmatches <$> (holeItemRegex `R.matchM` holeLine) -> - case getReplacement key of - Left replacement -> [leadingSpaces, replacement] - Right _ -> error $ - "Key " <> showBs key <> " requires replacement with an item, \ - \but list was given" - - | Just [_wholeMatch, leadingChars, key] <- - R.getAllTextSubmatches <$> (holeListRegex `R.matchM` holeLine) -> - case getReplacement key of - Left _ -> error $ - "Key " <> showBs key <> " requires replacement with a list, \ - \but an item was given" - Right [] -> - ["[]"] - Right replacements@(_ : _) -> - Unsafe.init $ do - replacement <- replacements - [leadingChars, replacement, "\n"] - - | otherwise -> - error $ "Unrecognized placeholder pattern " <> showBs holeLine - --- | Default config in textual representation. --- --- Sometimes you cannot just use 'defConfig' because clarifying comments --- would be lost. -defConfigText :: Flavor -> ByteString -defConfigText flavor = - flip fillHoles defConfigUnfilled - [ - "flavor" -: Left (show flavor) - - , "notScanned" -: Right $ case flavor of - GitHub -> - [ ".github/pull_request_template.md" - , ".github/issue_template.md" - , ".github/PULL_REQUEST_TEMPLATE/**/*" - , ".github/ISSUE_TEMPLATE/**/*" - ] - GitLab -> - [ ".gitlab/merge_request_templates/**/*" - , ".gitlab/issue_templates/**/*" - ] - - , "virtualFiles" -: Right $ case flavor of - GitHub -> - [ "../../../issues" - , "../../../issues/*" - , "../../../pulls" - , "../../../pulls/*" - ] - GitLab -> - [ "../../issues" - , "../../issues/*" - , "../../merge_requests" - , "../../merge_requests/*" - ] - ] +makeLensesWith postfixFields ''NetworkingConfig' defConfig :: HasCallStack => Flavor -> Config -defConfig flavor = normaliseConfigFilePaths $ - either (error . toText . prettyPrintParseException) id $ - decodeEither' (defConfigText flavor) +defConfig = either (error . toText . prettyPrintParseException) id + . decodeEither' + . encodeUtf8 + . defConfigText -- | Override missed fields with default values. overrideConfig :: ConfigOptional -> Config overrideConfig config = Config - { cTraversal = TraversalConfig ignored - , cVerification = maybe defVerification overrideVerify $ cVerification config - , cScanners = cScanners config + { cExclusions = maybe defExclusions overrideExclusions $ cExclusions config + , cNetworking = maybe defNetworking overrideNetworking $ cNetworking config + , cScanners = ScannersConfig + { scMarkdown = MarkdownConfig flavor + , scAnchorSimilarityThreshold = + fromMaybe (scAnchorSimilarityThreshold defScanners) + $ scAnchorSimilarityThreshold (cScanners config) + } } where flavor = mcFlavor . scMarkdown $ cScanners config - defTraversal = cTraversal $ defConfig flavor - - ignored = fromMaybe (tcIgnored defTraversal) $ tcIgnored =<< cTraversal config + defScanners = cScanners $ defConfig flavor + defExclusions = cExclusions $ defConfig flavor + defNetworking = cNetworking (defConfig flavor) + & ncExternalRefRedirectsL .~ [] - defVerification = cVerification $ defConfig flavor + overrideExclusions exclusionConfig + = ExclusionConfig + { ecIgnore = overrideField ecIgnore + , ecIgnoreLocalRefsTo = overrideField ecIgnoreLocalRefsTo + , ecIgnoreRefsFrom = overrideField ecIgnoreRefsFrom + , ecIgnoreExternalRefsTo = overrideField ecIgnoreExternalRefsTo + } + where + overrideField :: (forall f. ExclusionConfig' f -> Field f a) -> a + overrideField field = fromMaybe (field defExclusions) $ field exclusionConfig - overrideVerify verifyConfig - = VerifyConfig - { vcAnchorSimilarityThreshold = overrideField vcAnchorSimilarityThreshold - , vcExternalRefCheckTimeout = overrideField vcExternalRefCheckTimeout - , vcVirtualFiles = overrideField vcVirtualFiles - , vcNotScanned = overrideField vcNotScanned - , vcIgnoreRefs = overrideField vcIgnoreRefs - , vcIgnoreAuthFailures = overrideField vcIgnoreAuthFailures - , vcDefaultRetryAfter = overrideField vcDefaultRetryAfter - , vcMaxRetries = overrideField vcMaxRetries + overrideNetworking networkingConfig + = NetworkingConfig + { ncExternalRefCheckTimeout = overrideField ncExternalRefCheckTimeout + , ncIgnoreAuthFailures = overrideField ncIgnoreAuthFailures + , ncDefaultRetryAfter = overrideField ncDefaultRetryAfter + , ncMaxRetries = overrideField ncMaxRetries + , ncMaxTimeoutRetries = overrideField ncMaxTimeoutRetries + , ncMaxRedirectFollows = overrideField ncMaxRedirectFollows + , ncExternalRefRedirects = overrideField ncExternalRefRedirects } where - overrideField :: (forall f. VerifyConfig' f -> Field f a) -> a - overrideField field = fromMaybe (field defVerification) $ field verifyConfig + overrideField :: (forall f. NetworkingConfig' f -> Field f a) -> a + overrideField field = fromMaybe (field defNetworking) $ field networkingConfig ----------------------------------------------------------- -- Yaml instances @@ -242,37 +164,20 @@ parseJSON = withText "time" $ maybe (fail "Unknown time") pure . unitsP . toString -instance FromJSON Regex where - parseJSON = withText "regex" $ \val -> do - let errOrRegex = R.compile defaultCompOption defaultExecOption val - either (error . show) return errOrRegex - --- Default boolean values according to --- https://hackage.haskell.org/package/regex-tdfa-1.3.1.0/docs/Text-Regex-TDFA.html#t:CompOption -defaultCompOption :: CompOption -defaultCompOption = CompOption - { caseSensitive = True - , multiline = True - , rightAssoc = True - , newSyntax = True - , lastStarGreedy = False - } - --- ExecOption value to improve speed -defaultExecOption :: ExecOption -defaultExecOption = ExecOption {captureGroups = False} - instance FromJSON (ConfigOptional) where parseJSON = genericParseJSON aesonConfigOption instance FromJSON (Config) where parseJSON = genericParseJSON aesonConfigOption -instance FromJSON (VerifyConfig' Maybe) where +instance FromJSON (NetworkingConfig' Maybe) where parseJSON = genericParseJSON aesonConfigOption -instance FromJSON (VerifyConfig) where +instance FromJSON (NetworkingConfig) where parseJSON = genericParseJSON aesonConfigOption instance FromJSON (ScannersConfig) where + parseJSON = genericParseJSON aesonConfigOption + +instance FromJSON (ScannersConfig' Maybe) where parseJSON = genericParseJSON aesonConfigOption diff --git a/src/Xrefcheck/Config/Default.hs b/src/Xrefcheck/Config/Default.hs --- a/src/Xrefcheck/Config/Default.hs +++ b/src/Xrefcheck/Config/Default.hs @@ -3,47 +3,48 @@ - SPDX-License-Identifier: MPL-2.0 -} -{-# LANGUAGE QuasiQuotes #-} - module Xrefcheck.Config.Default where import Universum -import Text.RawString.QQ - -defConfigUnfilled :: ByteString -defConfigUnfilled = - [r|# Parameters of repository traversal. -traversal: - # Glob patterns describing files which we pretend do not exist - # (so they are neither analyzed nor can be referenced). - ignored: [] +import Fmt (Builder) +import Text.Interpolation.Nyan -# Verification parameters. -verification: - # On 'anchor not found' error, how much similar anchors should be displayed as - # hint. Number should be between 0 and 1, larger value means stricter filter. - anchorSimilarityThreshold: 0.5 +import Xrefcheck.Core +import Xrefcheck.Util - # When checking external references, how long to wait on request before - # declaring "Response timeout". - externalRefCheckTimeout: 10s +defConfigText :: Flavor -> Text +defConfigText flavor = + [int|D| +# Exclusion parameters. +exclusions: + # Ignore these files. References to them will fail verification, + # and references from them will not be verified. + # List of glob patterns. + ignore: [] - # Glob patterns describing the files, references in which should not be analyzed. - notScanned: - - :PLACEHOLDER:notScanned: + # References from these files will not be verified. + # List of glob patterns. + ignoreRefsFrom: +#{interpolateIndentF 4 $ interpolateBlockListF $ ignoreLocalRefsFrom} - # Glob patterns describing the files which do not physically exist in the - # repository but should be treated as existing nevertheless. - virtualFiles: - - :PLACEHOLDER:virtualFiles: + # References to these paths will not be verified. + # List of glob patterns. + ignoreLocalRefsTo: +#{interpolateIndentF 4 $ interpolateBlockListF $ ignoreLocalRefsTo} - # POSIX extended regular expressions that match external references - # that have to be ignored (not verified). - ignoreRefs: + # References to these URIs will not be verified. + # List of POSIX extended regular expressions. + ignoreExternalRefsTo: # Ignore localhost links by default - - ^(https?|ftps?)://(localhost|127\.0\.0\.1).* + - (https?|ftps?)://(localhost|127\\.0\\.0\\.1).* +# Networking parameters. +networking: + # When checking external references, how long to wait on request before + # declaring "Response timeout". + externalRefCheckTimeout: 10s + # Skip links which return 403 or 401 code. ignoreAuthFailures: true @@ -54,13 +55,110 @@ # How many attempts to retry an external link after getting # a "429 Too Many Requests" response. + # Timeouts may also be accounted here, see the description + # of `maxTimeoutRetries` field. + + # If a site once responded with 429 error code, subsequent + # request timeouts will also be treated as hitting the site's + # rate limiter and result in retry attempts, unless the + # maximum retries number has been reached. + # + # On other errors xrefcheck fails immediately, without retrying. maxRetries: 3 + # Querying a given domain that ever returned 429 before, + # this defines how many timeouts are allowed during retries. + # + # For such domains, timeouts likely mean hitting the rate limiter, + # and so xrefcheck considers timeouts in the same way as 429 errors. + # + # For other domains, a timeout results in a respective error, no retry + # attempts will be performed. Use `externalRefCheckTimeout` option + # to increase the time after which timeout is declared. + # + # This option is similar to `maxRetries`, the difference is that + # this `maxTimeoutRetries` option limits only the number of retries + # caused by timeouts, and `maxRetries` limits the number of retries + # caused both by 429s and timeouts. + maxTimeoutRetries: 1 + + # Maximum number of links that can be followed in a single redirect + # chain. + # + # The link is considered as invalid if the limit is exceeded. + maxRedirectFollows: 10 + + # Rules to override the redirect behavior for external references that + # match, where + # - 'from' is a regular expression for the source link in a single + # redirection step. Its absence means that every link matches. + # - 'to' is a regular expression for the target link in a single + # redirection step. Its absence also means that every link matches. + # - 'on' accepts 'temporary', 'permanent' or a specific redirect HTTP code. + # Its absence also means that every response code matches. + # - 'outcome' accepts 'valid', 'invalid' or 'follow'. The last one follows + # the redirect by applying the same configuration rules so, for instance, + # exclusion rules would also apply to the following links. + # + # The first one that matches is applied, and the link is considered + # as valid if none of them does match. + externalRefRedirects: +#{interpolateIndentF 4 externalRefRedirects} + # Parameters of scanners for various file types. scanners: + # On 'anchor not found' error, how much similar anchors should be displayed as + # hint. Number should be between 0 and 1, larger value means stricter filter. + anchorSimilarityThreshold: 0.5 + markdown: # Flavor of markdown, e.g. GitHub-flavor. # # This affects which anchors are generated for headers. - flavor: :PLACEHOLDER:flavor: + flavor: #s{flavor} |] + where + ignoreLocalRefsFrom :: NonEmpty Text + ignoreLocalRefsFrom = fromList $ case flavor of + GitHub -> + [ ".github/pull_request_template.md" + , ".github/issue_template.md" + , ".github/PULL_REQUEST_TEMPLATE/**/*" + , ".github/ISSUE_TEMPLATE/**/*" + ] + GitLab -> + [ ".gitlab/merge_request_templates/**/*" + , ".gitlab/issue_templates/**/*" + ] + + ignoreLocalRefsTo :: NonEmpty Text + ignoreLocalRefsTo = fromList $ case flavor of + GitHub -> + [ "../../../issues" + , "../../../issues/*" + , "../../../pulls" + , "../../../pulls/*" + ] + GitLab -> + [ "../../issues" + , "../../issues/*" + , "../../merge_requests" + , "../../merge_requests/*" + ] + + externalRefRedirects :: Builder + externalRefRedirects = case flavor of + GitHub -> + [int|| + - on: permanent + outcome: invalid|] + GitLab -> + [int|| + - on: permanent + outcome: invalid + # GitLab redirects non-existing files to the repository's main page + # with a 302 code instead of answering with a 404 response. + - from: https?://gitlab.com/.*/-/blob/.* + to: https?://gitlab.com/.* + on: 302 + outcome: invalid|] diff --git a/src/Xrefcheck/Core.hs b/src/Xrefcheck/Core.hs --- a/src/Xrefcheck/Core.hs +++ b/src/Xrefcheck/Core.hs @@ -9,24 +9,24 @@ module Xrefcheck.Core where -import Universum +import Universum hiding ((^..)) -import Control.Lens (makeLenses) +import Control.Lens (folded, makeLenses, makePrisms, to, united, (^..)) import Data.Aeson (FromJSON (..), withText) import Data.Char (isAlphaNum) import Data.Char qualified as C -import Data.Default (Default (..)) -import Data.List qualified as L +import Data.DList (DList) +import Data.DList qualified as DList import Data.Map qualified as M import Data.Reflection (Given) import Data.Text qualified as T -import Fmt (Buildable (..), blockListF, blockListF', nameF, (+|), (|+)) -import System.FilePath (isPathSeparator, pathSeparator) +import Fmt (Buildable (..), Builder) +import System.FilePath.Posix (isPathSeparator) +import Text.Interpolation.Nyan import Time (Second, Time) -import Data.DList (DList) -import Data.DList qualified as DList import Xrefcheck.Progress +import Xrefcheck.System import Xrefcheck.Util ----------------------------------------------------------- @@ -40,16 +40,16 @@ data Flavor = GitHub | GitLab - deriving stock (Show) + deriving stock (Show, Enum, Bounded) allFlavors :: [Flavor] -allFlavors = [GitHub, GitLab] - where - _exhaustivenessCheck = \case - GitHub -> () - GitLab -> () - -- if you update this, also update the list above +allFlavors = [minBound .. maxBound] +-- | Whether anchors are case-sensitive for a given Markdown flavour or not. +caseInsensitiveAnchors :: Flavor -> Bool +caseInsensitiveAnchors GitHub = True +caseInsensitiveAnchors GitLab = False + instance FromJSON Flavor where parseJSON = withText "flavor" $ \txt -> case T.toLower txt of @@ -60,25 +60,76 @@ -- | Description of element position in source file. -- We keep this in text because scanners for different formats use different -- representation of this thing, and it actually appears in reports only. -newtype Position = Position (Maybe Text) +newtype Position = Position Text deriving stock (Show, Eq, Generic) -instance Given ColorMode => Buildable Position where - build (Position pos) = case pos of - Nothing -> "" - Just p -> styleIfNeeded Faint $ "at src:" <> build p +instance Buildable Position where + build (Position pos) = build pos -- | Full info about a reference. data Reference = Reference - { rName :: Text + { rName :: Text -- ^ Text displayed as reference. - , rLink :: Text - -- ^ File or site reference points to. - , rAnchor :: Maybe Text + , rPos :: Position + -- ^ Position in source file. + , rInfo :: ReferenceInfo + -- ^ More info about the reference. + } deriving stock (Show, Generic) + +-- | Info about the reference. +data ReferenceInfo + = RIExternal ExternalLink + | RIFile ReferenceInfoFile + deriving stock (Show, Generic) + +data ReferenceInfoFile = ReferenceInfoFile + { rifAnchor :: Maybe Text -- ^ Section or custom anchor tag. - , rPos :: Position + , rifLink :: FileLink + -- ^ More info about the link. } deriving stock (Show, Generic) +data ExternalLink + = ELUrl Text + -- ^ Reference to a file at outer site, e.g @[d](http://www.google.com/doodles)@. + | ELOther Text + -- ^ Entry not to be processed, e.g. @mailto:e-mail@. + deriving stock (Show, Generic) + +data FileLink + = FLAbsolute RelPosixLink + -- ^ Reference to a file or directory relative to the repository root. + | FLRelative RelPosixLink + -- ^ Reference to a file or directory relative to the given one. + | FLLocal + -- ^ Reference to this file. + deriving stock (Show, Generic) + +makePrisms ''ReferenceInfo +makePrisms ''ExternalLink + +pattern PathSep :: Char +pattern PathSep <- (isPathSeparator -> True) + +-- | Compute the 'ReferenceInfo' corresponding to a given link. +referenceInfo :: Text -> ReferenceInfo +referenceInfo url + | hasUrlProtocol = RIExternal $ ELUrl url + | hasProtocol = RIExternal $ ELOther url + | null link = RIFile $ ReferenceInfoFile anchor FLLocal + | otherwise = case T.uncons link of + Just (PathSep, path) -> + RIFile $ ReferenceInfoFile anchor $ FLAbsolute $ RelPosixLink path + _ -> + RIFile $ ReferenceInfoFile anchor $ FLRelative $ RelPosixLink link + where + hasUrlProtocol = "://" `T.isInfixOf` T.take 10 url + hasProtocol = ":" `T.isInfixOf` T.take 10 url + (link, anchor) = case T.splitOn "#" url of + [t] -> (t, Nothing) + t : ts -> (t, Just $ T.intercalate "#" ts) + [] -> (url, Nothing) + -- | Context of anchor. data AnchorType = HeaderAnchor Int @@ -119,42 +170,104 @@ } deriving stock (Show, Generic) makeLenses ''FileInfo -instance Default FileInfo where - def = diffToFileInfo mempty +data ScanPolicy + = OnlyTracked + -- ^ Scan and treat as existing only files tracked by Git. + -- Warn when there are scannable files not added to Git yet. + | IncludeUntracked + -- ^ Also scan and treat as existing + -- files that were neither tracked nor ignored by Git. + deriving stock (Show, Eq) +data FileStatus + = Scanned FileInfo + | NotScannable + -- ^ Files that are not supported by our scanners. + | NotAddedToGit + -- ^ We are not scanning files that are not added to git + -- unless --include-untracked CLI option was enabled, but we're + -- gathering information about them to improve reports. + deriving stock (Show) + +data DirectoryStatus + = TrackedDirectory + | UntrackedDirectory + deriving stock (Show) + -- | All tracked files and directories. data RepoInfo = RepoInfo - { riFiles :: Map FilePath (Maybe FileInfo) - -- ^ Files from the repo with `FileInfo` attached to files that we can scan. - , riDirectories :: Set FilePath - -- ^ Tracked directories. - } deriving stock (Show) + { riFiles :: Map CanonicalRelPosixLink (RelPosixLink, FileStatus) + -- ^ Files from the repo with `FileInfo` attached to files that we've scanned. + , riDirectories :: Map CanonicalRelPosixLink (RelPosixLink, DirectoryStatus) + -- ^ Directories containing those files. + } +-- Search for a file in the repository. +lookupFile :: CanonicalRelPosixLink -> RepoInfo -> Maybe FileStatus +lookupFile path RepoInfo{..} = + snd <$> M.lookup path riFiles + +-- Search for a directory in the repository. +lookupDirectory :: CanonicalRelPosixLink -> RepoInfo -> Maybe DirectoryStatus +lookupDirectory path RepoInfo{..} = + snd <$> M.lookup path riDirectories + ----------------------------------------------------------- -- Instances ----------------------------------------------------------- -instance NFData Position -instance NFData Reference -instance NFData AnchorType +instance NFData ReferenceInfo instance NFData Anchor +instance NFData AnchorType +instance NFData ExternalLink instance NFData FileInfo +instance NFData FileLink +instance NFData Position +instance NFData Reference +instance NFData ReferenceInfoFile instance Given ColorMode => Buildable Reference where build Reference{..} = - nameF ("reference " +| paren (build loc) |+ " " +| rPos |+ "") $ - blockListF - [ "text: " <> show rName - , "link: " <> build rLink - , "anchor: " <> build (rAnchor ?: styleIfNeeded Faint "-") - ] - where - loc = locationType rLink + case rInfo of + RIFile ReferenceInfoFile{..} -> + case rifLink of + FLLocal -> + [int|| + reference #{paren $ colorIfNeeded Green "file-local"} at #{rPos}: + - text: #s{rName} + - anchor: #{rifAnchor ?: styleIfNeeded Faint "-"} + |] + FLRelative link -> + [int|| + reference #{paren $ colorIfNeeded Yellow "relative"} at #{rPos}: + - text: #s{rName} + - link: #{link} + - anchor: #{rifAnchor ?: styleIfNeeded Faint "-"} + |] + FLAbsolute link -> + [int|| + reference #{paren $ colorIfNeeded Yellow "absolute"} at #{rPos}: + - text: #s{rName} + - link: /#{link} + - anchor: #{rifAnchor ?: styleIfNeeded Faint "-"} + |] + RIExternal (ELUrl url) -> + [int|| + reference #{paren $ colorIfNeeded Red "external"} at #{rPos}: + - text: #s{rName} + - link: #{url} + |] + RIExternal (ELOther url) -> + [int|| + reference (other) at #{rPos}: + - text: #s{rName} + - link: #{url} + |] instance Given ColorMode => Buildable AnchorType where build = styleIfNeeded Faint . \case HeaderAnchor l -> colorIfNeeded Green ("header " <> headerLevelToRoman l) - HandAnchor -> colorIfNeeded Yellow "hand made" + HandAnchor -> colorIfNeeded Yellow "handmade" BiblioAnchor -> colorIfNeeded Cyan "biblio" where headerLevelToRoman = \case @@ -167,82 +280,37 @@ n -> error "Bad header level: " <> show n instance Given ColorMode => Buildable Anchor where - build (Anchor t a p) = a |+ " (" +| t |+ ") " +| p |+ "" + build Anchor{..} = + [int|| + #{aName} (#{aType}) at #{aPos} + |] instance Given ColorMode => Buildable FileInfo where - build FileInfo{..} = blockListF - [ nameF "references" $ blockListF _fiReferences - , nameF "anchors" $ blockListF _fiAnchors - ] + build FileInfo{..} = + [int|| + - references: + #{ interpolateIndentF 4 $ maybe "none" interpolateBlockListF (nonEmpty _fiReferences) } + - anchors: + #{ interpolateIndentF 4 $ maybe "none" interpolateBlockListF (nonEmpty _fiAnchors) } + |] instance Given ColorMode => Buildable RepoInfo where - build (RepoInfo m _) = - blockListF' "⮚" buildFileReport (mapMaybe sequence $ M.toList m) + build RepoInfo{..} + | Just scanned <- nonEmpty [(name, info) | (_, (name, Scanned info)) <- toPairs riFiles] + = interpolateUnlinesF $ buildFileReport <$> scanned where - buildFileReport (name, info) = mconcat - [ colorIfNeeded Cyan $ fromString name <> ":\n" - , build info - , "\n" - ] + buildFileReport :: (RelPosixLink, FileInfo) -> Builder + buildFileReport (name, info) = + [int|| + #{ colorIfNeeded Cyan name }: + #{ interpolateIndentF 2 $ build info } + |] + build _ = "No scannable files found." ----------------------------------------------------------- -- Analysing ----------------------------------------------------------- -pattern PathSep :: Char -pattern PathSep <- (isPathSeparator -> True) - --- | Type of reference. -data LocationType - = CurrentFileLoc - -- ^ Reference to this file, e.g. @[a](#header)@ - | RelativeLoc - -- ^ Reference to a file relative to given one, e.g. @[b](folder/file#header)@ - | AbsoluteLoc - -- ^ Reference to a file relative to the root, e.g. @[c](/folder/file#header)@ - | ExternalLoc - -- ^ Reference to a file at outer site, e.g @[d](http://www.google.com/doodles)@ - | OtherLoc - -- ^ Entry not to be processed, e.g. @mailto:e-mail@ - deriving stock (Eq, Show) - -instance Given ColorMode => Buildable LocationType where - build = \case - CurrentFileLoc -> colorIfNeeded Green "current file" - RelativeLoc -> colorIfNeeded Yellow "relative" - AbsoluteLoc -> colorIfNeeded Blue "absolute" - ExternalLoc -> colorIfNeeded Red "external" - OtherLoc -> "" - --- | Whether this is a link to external resource. -isExternal :: LocationType -> Bool -isExternal = \case - ExternalLoc -> True - _ -> False - --- | Whether this is a link to repo-local resource. -isLocal :: LocationType -> Bool -isLocal = \case - CurrentFileLoc -> True - RelativeLoc -> True - AbsoluteLoc -> True - ExternalLoc -> False - OtherLoc -> False - --- | Get type of reference. -locationType :: Text -> LocationType -locationType location = case toString location of - [] -> CurrentFileLoc - PathSep : _ -> AbsoluteLoc - '.' : PathSep : _ -> RelativeLoc - '.' : '.' : PathSep : _ -> RelativeLoc - _ | hasUrlProtocol -> ExternalLoc - | hasProtocol -> OtherLoc - | otherwise -> RelativeLoc - where - hasUrlProtocol = "://" `T.isInfixOf` T.take 10 location - hasProtocol = ":" `T.isInfixOf` T.take 10 location - -- | Which parts of verification do we perform. data VerifyMode = LocalOnlyMode @@ -304,29 +372,22 @@ guard (length strippedNo < length t) T.stripSuffix "-" strippedNo --- | Strip './' prefix from local references. -canonizeLocalRef :: Text -> Text -canonizeLocalRef ref = - maybe ref canonizeLocalRef (T.stripPrefix localPrefix ref) - where - localPrefix = toText ['.', pathSeparator] - ----------------------------------------------------------- -- Visualisation ----------------------------------------------------------- data VerifyProgress = VerifyProgress - { vrLocal :: !(Progress Int) - , vrExternal :: !(Progress Int) + { vrLocal :: !(Progress Int ()) + , vrExternal :: !(Progress Int Text) } deriving stock (Show) initVerifyProgress :: [Reference] -> VerifyProgress initVerifyProgress references = VerifyProgress - { vrLocal = initProgress (length localRefs) - , vrExternal = initProgress (length (L.nubBy ((==) `on` rLink) extRefs)) + { vrLocal = initProgressWitnessed $ + references ^.. folded . to rInfo . (_RIFile . united <> _RIExternal . _ELOther . united) + , vrExternal = initProgressWitnessed . ordNub $ + references ^.. folded . to rInfo . _RIExternal . _ELUrl } - where - (extRefs, localRefs) = L.partition (isExternal . locationType . rLink) references showAnalyseProgress :: Given ColorMode => VerifyMode -> Time Second -> VerifyProgress -> Text showAnalyseProgress mode posixTime VerifyProgress{..} = diff --git a/src/Xrefcheck/Data/Redirect.hs b/src/Xrefcheck/Data/Redirect.hs new file mode 100644 --- /dev/null +++ b/src/Xrefcheck/Data/Redirect.hs @@ -0,0 +1,170 @@ +{- SPDX-FileCopyrightText: 2022 Serokell + - + - SPDX-License-Identifier: MPL-2.0 + -} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Xrefcheck.Data.Redirect + ( RedirectChain + , RedirectChainLink (..) + , emptyChain + , pushRequest + , hasRequest + , totalFollowed + + , RedirectRule (..) + , RedirectRuleOn (..) + , RedirectRuleOutcome (..) + , redirectRule + + , isPermanentRedirectCode + , isRedirectCode + , isTemporaryRedirectCode + ) where + +import Universum + +import Data.Aeson (genericParseJSON) +import Data.Yaml (FromJSON (..), withText) +import Fmt (Buildable (..)) +import Text.Regex.TDFA.Text (Regex) + +import Data.Sequence ((|>)) +import Xrefcheck.Scan () +import Xrefcheck.Util + +-- | A custom redirect rule. +data RedirectRule = RedirectRule + { rrFrom :: Maybe Regex + -- ^ Redirect source links that match to apply the rule. + -- + -- 'Nothing' matches any link. + , rrTo :: Maybe Regex + -- ^ Redirect target links that match to apply the rule. + -- + -- 'Nothing' matches any link. + , rrOn :: Maybe RedirectRuleOn + -- ^ HTTP code selector to apply the rule. + -- + -- 'Nothing' matches any code. + , rrOutcome :: RedirectRuleOutcome + -- ^ What to do when an HTTP response matches the rule. + } deriving stock (Generic) + +-- | Rule selector depending on the response HTTP code. +data RedirectRuleOn + = RROCode Int + -- ^ An exact HTTP code + | RROPermanent + -- ^ Any HTTP code considered as permanent according to 'isPermanentRedirectCode' + | RROTemporary + -- ^ Any HTTP code considered as permanent according to 'isTemporaryRedirectCode' + deriving stock (Show, Eq) + +-- | What to do when receiving a redirect HTTP response. +data RedirectRuleOutcome + = RROValid + -- ^ Consider it as valid + | RROInvalid + -- ^ Consider it as invalid + | RROFollow + -- ^ Try again by following the redirect + deriving stock (Show, Eq) + +-- | Links in a redirection chain. +newtype RedirectChain = RedirectChain + { unRedirectChain :: Seq RedirectChainLink + } deriving newtype (Show, Eq) + +-- | A single link in a redirection chain. +newtype RedirectChainLink = RedirectChainLink + { unRedirectChainLink :: Text + } deriving newtype (Show, Eq) + +instance FromList RedirectChain where + type ListElement RedirectChain = Text + fromList = RedirectChain . fromList . fmap RedirectChainLink + +emptyChain :: RedirectChain +emptyChain = RedirectChain mempty + +pushRequest :: RedirectChain -> RedirectChainLink -> RedirectChain +pushRequest (RedirectChain chain) = RedirectChain . (chain |>) + +hasRequest :: RedirectChain -> RedirectChainLink -> Bool +hasRequest (RedirectChain chain) = (`elem` chain) + +totalFollowed :: RedirectChain -> Int +totalFollowed = length . unRedirectChain + +instance Buildable RedirectChain where + build (RedirectChain linksStack) = build chainText + where + link (True, RedirectChainLink l) = "-| " <> l + link (False, RedirectChainLink l) = "-> " <> l + + chainText = mconcat + $ intersperse "\n" + $ fmap link + $ zip (True : repeat False) + $ toList linksStack + +-- | Redirect rule to apply to a link when it has been responded with a given +-- HTTP code. +redirectRule :: Text -> Text -> Int -> [RedirectRule] -> Maybe RedirectRule +redirectRule source target code rules = + find (matchRule source target code) rules + +-- | Check if a 'RedirectRule' matches a given link and HTTP code. +matchRule :: Text -> Text -> Int -> RedirectRule -> Bool +matchRule source target code RedirectRule{..} = and + [ matchCode + , matchLink source rrFrom + , matchLink target rrTo + ] + where + matchCode = case rrOn of + Nothing -> True + Just RROPermanent -> isPermanentRedirectCode code + Just RROTemporary -> isTemporaryRedirectCode code + Just (RROCode other) -> code == other + + matchLink link = \case + Nothing -> True + Just regex -> doesMatchAnyRegex link [regex] + +isRedirectCode :: Int -> Bool +isRedirectCode code = code >= 300 && code < 400 + +isTemporaryRedirectCode :: Int -> Bool +isTemporaryRedirectCode = flip elem [302, 303, 307] + +isPermanentRedirectCode :: Int -> Bool +isPermanentRedirectCode = flip elem [301, 308] + +instance FromJSON (RedirectRule) where + parseJSON = genericParseJSON aesonConfigOption + +instance FromJSON (RedirectRuleOutcome) where + parseJSON = withText "Redirect rule outcome" $ + \case + "valid" -> pure RROValid + "invalid" -> pure RROInvalid + "follow" -> pure RROFollow + _ -> fail "expected (valid|invalid|follow)" + +instance FromJSON (RedirectRuleOn) where + parseJSON v = code v + <|> text v + <|> fail "expected a redirect (3XX) HTTP code or (permanent|temporary)" + where + code cv = do + i <- parseJSON cv + guard $ isRedirectCode i + pure $ RROCode i + text = withText "Redirect rule on" $ + \case + "permanent" -> pure RROPermanent + "temporary" -> pure RROTemporary + _ -> mzero diff --git a/src/Xrefcheck/Data/URI.hs b/src/Xrefcheck/Data/URI.hs new file mode 100644 --- /dev/null +++ b/src/Xrefcheck/Data/URI.hs @@ -0,0 +1,74 @@ +{- SPDX-FileCopyrightText: 2023 Serokell + - + - SPDX-License-Identifier: MPL-2.0 + -} + +{-# LANGUAGE ExistentialQuantification #-} + +module Xrefcheck.Data.URI + ( UriParseError (..) + , parseUri + ) where + +import Universum + +import Control.Exception.Safe (handleJust) +import Control.Monad.Except (throwError) +import Text.URI (ParseExceptionBs, URI, mkURIBs) +import URI.ByteString qualified as URIBS + +data UriParseError + = UPEInvalid URIBS.URIParseError + | UPEConversion ParseExceptionBs + deriving stock (Show, Eq) + +data AnyURIRef = forall a. AnyURIRef (URIBS.URIRef a) + +serializeAnyURIRef :: AnyURIRef -> ByteString +serializeAnyURIRef (AnyURIRef uri) = URIBS.serializeURIRef' uri + +-- | Parse URI according to RFC 3986 extended by allowing non-encoded +-- `[` and `]` in query string. +-- +-- The first parameter indicates whether the parsing should admit relative +-- URIs or not. +parseUri :: Bool -> Text -> ExceptT UriParseError IO URI +parseUri canBeRelative link = do + -- There exist two main standards of URL parsing: RFC 3986 and the Web + -- Hypertext Application Technology Working Group's URL standard. Ideally, + -- we want to be able to parse the URLs in accordance with the latter + -- standard, because it provides a much less ambiguous set of rules for + -- percent-encoding special characters, and is essentially a living + -- standard that gets updated constantly. + -- + -- We have chosen the 'uri-bytestring' library for URI parsing because + -- of the 'laxURIParseOptions' parsing configuration. 'mkURI' from + -- the 'modern-uri' library parses URIs in accordance with RFC 3986 and does + -- not provide a means of parsing customization, which contrasts with + -- 'parseURI' that accepts a 'URIParserOptions'. One of the predefined + -- configurations of this type is 'strictURIParserOptions', which follows + -- RFC 3986, and the other -- 'laxURIParseOptions' -- allows brackets + -- in the queries, which draws us closer to the WHATWG URL standard. + -- + -- The 'modern-uri' package can parse an URI deciding if it is absolute or + -- relative depending on the success or failure of the scheme parsing. By + -- contrast, in 'uri-bytestring' it has to be decided beforehand, resulting in + -- different URI types. + uri <- case URIBS.parseURI URIBS.laxURIParserOptions (encodeUtf8 link) of + Left (URIBS.MalformedScheme _) | canBeRelative -> + URIBS.parseRelativeRef URIBS.laxURIParserOptions (encodeUtf8 link) + & either (throwError . UPEInvalid) (pure . AnyURIRef) + Left err -> throwError $ UPEInvalid err + Right uri -> pure $ AnyURIRef uri + + -- We stick to our infrastructure by continuing to operate on the datatypes + -- from 'modern-uri', which are used in the 'req' library. First we + -- serialize our URI parsed with 'parseURI' so it becomes a 'ByteString' + -- with all the necessary special characters *percent-encoded*, and then + -- call 'mkURIBs'. + mkURIBs (serializeAnyURIRef uri) + -- Ideally, this exception should never be thrown, as the URI + -- already *percent-encoded* with 'parseURI' from 'uri-bytestring' + -- and 'mkURIBs' is only used to convert to 'URI' type from + -- 'modern-uri' package. + & handleJust fromException (throwError . UPEConversion) diff --git a/src/Xrefcheck/Orphans.hs b/src/Xrefcheck/Orphans.hs --- a/src/Xrefcheck/Orphans.hs +++ b/src/Xrefcheck/Orphans.hs @@ -13,9 +13,10 @@ import Data.ByteString.Char8 qualified as C -import Fmt (Buildable (..), unlinesF, (+|), (|+)) +import Fmt (Buildable (..)) import Network.FTP.Client (FTPException (..), FTPMessage (..), FTPResponse (..), ResponseStatus (..)) +import Text.Interpolation.Nyan import Text.URI (RText, unRText) import URI.ByteString (SchemaError (..), URIParseError (..)) @@ -33,10 +34,11 @@ ) instance Buildable FTPResponse where - build FTPResponse{..} = unlinesF - [ frStatus |+ " (" +| frCode |+ "):" - , build frMessage - ] + build FTPResponse{..} = + [int|| + #{frStatus} (#{frCode}): + #{frMessage} + |] instance Buildable FTPException where build (BadProtocolResponseException _) = "Raw FTP exception" diff --git a/src/Xrefcheck/Progress.hs b/src/Xrefcheck/Progress.hs --- a/src/Xrefcheck/Progress.hs +++ b/src/Xrefcheck/Progress.hs @@ -9,16 +9,17 @@ TaskTimestamp (..) -- * Progress - , Progress (..) + , Progress , initProgress - , incProgress - , incProgressUnfixableErrors - , incProgressFixableErrors - , decProgressFixableErrors - , fixableToUnfixable + , initProgressWitnessed + , reportSuccess + , reportError + , reportRetry + , getTaskTimestamp , setTaskTimestamp , removeTaskTimestamp , checkTaskTimestamp + , sameProgress , showProgress -- * Printing @@ -31,6 +32,7 @@ import Data.Ratio ((%)) import Data.Reflection (Given) +import Data.Set qualified as S import Time (Second, Time, sec, unTime, (-:-)) import Xrefcheck.Util @@ -44,7 +46,7 @@ data TaskTimestamp = TaskTimestamp { ttTimeToCompletion :: Time Second -- ^ The amount of time required for the task to be completed. - , ttStart :: Time Second + , ttStart :: Time Second -- ^ The timestamp of when the task had started, represented by the number of seconds -- since the Unix epoch. } deriving stock (Show) @@ -53,72 +55,96 @@ -- Progress ----------------------------------------------------------- --- | Processing progress of any thing. -data Progress a = Progress - { pTotal :: a +-- | Processing progress of any thing, measured with type @a@, where progress units have witnesses +-- of type @w@ that can be retried. +-- +-- The () type can be used as a trivial witness if the retry logic is not going to be used. +data Progress a w = Progress + { pTotal :: !a -- ^ Overall amount of work. - , pCurrent :: a - -- ^ How much has been completed. - , pErrorsUnfixable :: !a - -- ^ How much of the completed work finished with an unfixable error. - , pErrorsFixable :: !a - -- ^ How much of the completed work finished with an error that can be - -- eliminated upon further verification. - , pTaskTimestamp :: Maybe TaskTimestamp + , pSuccess :: !a + -- ^ How much has been completed with success. + , pError :: !a + -- ^ How much has been completed with error. + , pRetrying :: !(S.Set w) + -- ^ Witnesses of items that have been completed with error but are being retried. + , pTaskTimestamp :: !(Maybe TaskTimestamp) -- ^ A timestamp of an anonymous timer task, where its time to completion is -- the time needed to pass for the action to be retried immediately after. } deriving stock (Show) -- | Initialise null progress. -initProgress :: Num a => a -> Progress a -initProgress a = Progress{ pTotal = a - , pCurrent = 0 - , pErrorsUnfixable = 0 - , pErrorsFixable = 0 - , pTaskTimestamp = Nothing - } +initProgress :: Num a => a -> Progress a w +initProgress a = Progress + { pTotal = a + , pSuccess = 0 + , pError = 0 + , pRetrying = S.empty + , pTaskTimestamp = Nothing + } --- | Increase progress amount. -incProgress :: (Num a) => Progress a -> Progress a -incProgress Progress{..} = Progress{ pCurrent = pCurrent + 1, .. } +-- | Initialise null progress from a given list of witnesses. +-- +-- This just initializes it with as many work to do as witnesses are in the list, so you can be +-- more confident regarding the progress initialization because you actualy provided data that +-- represents each unit of work to do. +initProgressWitnessed :: [w] -> Progress Int w +initProgressWitnessed ws = Progress + { pTotal = length ws + , pSuccess = 0 + , pError = 0 + , pRetrying = S.empty + , pTaskTimestamp = Nothing + } --- | Increase the number of unfixable errors. -incProgressUnfixableErrors :: (Num a) => Progress a -> Progress a -incProgressUnfixableErrors Progress{..} = Progress{ pErrorsUnfixable = pErrorsUnfixable + 1 - , .. - } +-- | Report a unit of success with witness @item@. +reportSuccess :: (Num a, Ord w) => w -> Progress a w -> Progress a w +reportSuccess item Progress{..} = Progress + { pSuccess = pSuccess + 1 + , pRetrying = S.delete item pRetrying + , .. + } --- | Increase the number of fixable errors. -incProgressFixableErrors :: (Num a) => Progress a -> Progress a -incProgressFixableErrors Progress{..} = Progress{ pErrorsFixable = pErrorsFixable + 1 - , .. - } +-- | Report a unit of failure with witness @item@. +reportError :: (Num a, Ord w) => w -> Progress a w -> Progress a w +reportError item Progress{..} = Progress + { pError = pError + 1 + , pRetrying = S.delete item pRetrying + , .. + } --- | Decrease the number of fixable errors. This function indicates the situation where one of --- such errors had been successfully eliminated. -decProgressFixableErrors :: (Num a) => Progress a -> Progress a -decProgressFixableErrors Progress{..} = Progress{ pErrorsFixable = pErrorsFixable - 1 - , .. - } +-- | Report a unit of failure and retry intention with witness @item@. +reportRetry :: Ord w => w -> Progress a w -> Progress a w +reportRetry item Progress{..} = Progress + { pRetrying = S.insert item pRetrying + , .. + } -fixableToUnfixable :: (Num a) => Progress a -> Progress a -fixableToUnfixable Progress{..} = Progress{ pErrorsFixable = pErrorsFixable - 1 - , pErrorsUnfixable = pErrorsUnfixable + 1 - , .. - } +-- | Set the current `TaskTimestamp`. +-- +-- It does require a witness because, although the `TaskTimestamp` is +-- anonymous, at this point an actual task should be responsible for +-- registering this timestamp. +setTaskTimestamp :: w -> Time Second -> Time Second -> Progress a w -> Progress a w +setTaskTimestamp _ ttc startTime Progress{..} = Progress + { pTaskTimestamp = Just (TaskTimestamp ttc startTime) + , .. + } -setTaskTimestamp :: Time Second -> Time Second -> Progress a -> Progress a -setTaskTimestamp ttc startTime Progress{..} = Progress{ pTaskTimestamp = - Just $ TaskTimestamp ttc startTime - , .. - } +-- | Get the current `TaskTimestamp`. +-- +-- It does not require a witness because the `TaskTimestamp` is anonymous +-- and anyone should be able to observe it. +getTaskTimestamp :: Progress a w -> Maybe TaskTimestamp +getTaskTimestamp = pTaskTimestamp -removeTaskTimestamp :: Progress a -> Progress a -removeTaskTimestamp Progress{..} = Progress{ pTaskTimestamp = Nothing - , .. - } +removeTaskTimestamp :: Progress a w -> Progress a w +removeTaskTimestamp Progress{..} = Progress + { pTaskTimestamp = Nothing + , .. + } -checkTaskTimestamp :: Time Second -> Progress a -> Progress a +checkTaskTimestamp :: Time Second -> Progress a w -> Progress a w checkTaskTimestamp posixTime p@Progress{..} = case pTaskTimestamp of Nothing -> p @@ -127,8 +153,21 @@ then p else removeTaskTimestamp p +-- | Check whether the two @Progress@ values are equal up to similarity of their essential +-- components, ignoring the comparison of @pTaskTimestamp@s, which is done to prevent test +-- failures when comparing the resulting progress, gotten from running the link +-- verification algorithm, with the expected one, where @pTaskTimestamp@ is hardcoded +-- as @Nothing@. +sameProgress :: (Eq a, Eq w) => Progress a w -> Progress a w -> Bool +sameProgress p1 p2 = and + [ ((==) `on` pTotal) p1 p2 + , ((==) `on` pSuccess) p1 p2 + , ((==) `on` pError) p1 p2 + , ((==) `on` pRetrying) p1 p2 + ] + -- | Visualise progress bar. -showProgress :: Given ColorMode => Text -> Int -> Color -> Time Second -> Progress Int -> Text +showProgress :: Given ColorMode => Text -> Int -> Color -> Time Second -> Progress Int w -> Text showProgress name width col posixTime Progress{..} = mconcat [ colorIfNeeded col (name <> ": [") , toText bar @@ -137,18 +176,18 @@ , status ] where - -- | Each of the following values represents the number of the progress bar cells + -- Each of the following values represents the number of the progress bar cells -- corresponding to the respective "class" of processed references: the valid ones, -- the ones containing an unfixable error (a.k.a. the invalid ones), and the ones -- containing a fixable error. -- -- The current overall number of proccessed errors. - done = floor $ (pCurrent % pTotal) * fromIntegral @Int @(Ratio Int) width + done = floor $ (current % pTotal) * fromIntegral @Int @(Ratio Int) width - -- | The current number of the invalid references. - errsU = ceiling $ (pErrorsUnfixable % pTotal) * fromIntegral @Int @(Ratio Int) width + -- The current number of the invalid references. + errsU = ceiling $ (pError % pTotal) * fromIntegral @Int @(Ratio Int) width - -- | The current number of (fixable) errors that may be eliminated during further + -- The current number of (fixable) errors that may be eliminated during further -- verification. -- Notice! -- 1. Both this and the previous values use @ceiling@ as the rounding function. @@ -157,16 +196,16 @@ -- to be visible in the progress bar visualization. -- 2. @errsF@ is bounded from above by @width - errsU@ to prevent an overflow in the -- number of the progress bar cells that could be caused by the two @ceilings@s. - errsF = min (width - errsU) . ceiling $ (pErrorsFixable % pTotal) * + errsF = min (width - errsU) . ceiling $ (fixable % pTotal) * fromIntegral @Int @(Ratio Int) width - -- | The number of valid references. + -- The number of valid references. -- The value is bounded from below by 0 to ensure the number never gets negative. -- This situation is plausible due to the different rounding functions used for each value: -- @floor@ for the minuend @done@, @ceiling@ for the two subtrahends @errsU@ & @errsF@. successful = max 0 $ done - errsU - errsF - -- | The remaining number of references to be verified. + -- The remaining number of references to be verified. remaining = width - successful - errsU - errsF bar @@ -186,16 +225,22 @@ $ ttTimeToCompletion -:- (posixTime -:- ttStart) ] status = mconcat - [ if pCurrent == pTotal && pErrorsFixable == 0 && pErrorsUnfixable == 0 + [ if current == pTotal && fixable == 0 && pError == 0 then styleIfNeeded Faint $ colorIfNeeded White "✓" else "" - , if pErrorsFixable /= 0 then colorIfNeeded Blue "!" else "" - , if pErrorsUnfixable /= 0 then colorIfNeeded Red "!" else "" + , if fixable /= 0 then colorIfNeeded Blue "!" else "" + , if pError /= 0 then colorIfNeeded Red "!" else "" ] timeSecondCeiling :: Time Second -> Time Second timeSecondCeiling = sec . fromInteger . ceiling . unTime + fixable :: Int + fixable = S.size pRetrying + + current :: Int + current = pSuccess + pError + fixable + ----------------------------------------------------------- -- Rewritable output ----------------------------------------------------------- @@ -237,7 +282,7 @@ atomicModifyIORef' rMaxPrintedSize $ \maxPrinted -> (max maxPrinted (length msg), ()) where - -- | The maximum possible difference between two progress text representations, + -- The maximum possible difference between two progress text representations, -- including the timer & the status, is 9 characters. This is a temporary -- solution to the problem of re-printing a smaller string on top of another -- that'll leave some of the trailing characters in the original string diff --git a/src/Xrefcheck/Scan.hs b/src/Xrefcheck/Scan.hs --- a/src/Xrefcheck/Scan.hs +++ b/src/Xrefcheck/Scan.hs @@ -3,85 +3,138 @@ - SPDX-License-Identifier: MPL-2.0 -} +{-# OPTIONS_GHC -Wno-orphans #-} + -- | Generalised repo scanner and analyser. module Xrefcheck.Scan - ( TraversalConfig - , TraversalConfig' (..) - , Extension + ( ExclusionConfig + , ExclusionConfig' (..) + , FileSupport + , ReadDirectoryMode(..) , ScanAction - , FormatsSupport - , RepoInfo (..) , ScanError (..) , ScanErrorDescription (..) , ScanResult (..) + , ScanStage (..) - , normaliseTraversalConfigFilePaths + , defaultCompOption + , defaultExecOption + , ecIgnoreL + , ecIgnoreLocalRefsToL + , ecIgnoreRefsFromL + , ecIgnoreExternalRefsToL + , firstFileSupport + , mkGatherScanError + , mkParseScanError + , reportScanErrs , scanRepo - , specificFormatsSupport ) where -import Universum +import Universum hiding (_1, (%~)) -import Data.Aeson (FromJSON (..), genericParseJSON) -import Data.List qualified as L +import Control.Lens (_1, makeLensesWith, (%~)) +import Data.Aeson (FromJSON (..), genericParseJSON, withText) import Data.Map qualified as M import Data.Reflection (Given) -import Fmt (Buildable (..), nameF, (+|), (|+)) -import System.Directory (doesDirectoryExist) -import System.FilePath - (dropTrailingPathSeparator, equalFilePath, splitDirectories, takeDirectory, takeExtension, ()) +import Fmt (Buildable (..), Builder, fmtLn) +import System.Directory (doesDirectoryExist, pathIsSymbolicLink) import System.Process (cwd, readCreateProcess, shell) +import Text.Interpolation.Nyan +import Text.Regex.TDFA.Common (CompOption (..), ExecOption (..), Regex) +import Text.Regex.TDFA.Text qualified as R import Xrefcheck.Core import Xrefcheck.Progress -import Xrefcheck.System (RelGlobPattern, matchesGlobPatterns, normaliseGlobPattern, readingSystem) +import Xrefcheck.System import Xrefcheck.Util --- | Type alias for TraversalConfig' with all required fields. -type TraversalConfig = TraversalConfig' Identity +-- | Type alias for ExclusionConfig' with all required fields. +type ExclusionConfig = ExclusionConfig' Identity --- | Config of repositry traversal. -data TraversalConfig' f = TraversalConfig - { tcIgnored :: Field f [RelGlobPattern] - -- ^ Files and folders, files in which we completely ignore. +-- | Config of repositry exclusions. +data ExclusionConfig' f = ExclusionConfig + { ecIgnore :: Field f [CanonicalRelGlobPattern] + -- ^ Files which we completely ignore. + , ecIgnoreLocalRefsTo :: Field f [CanonicalRelGlobPattern] + -- ^ Files references to which we do not verify. + , ecIgnoreRefsFrom :: Field f [CanonicalRelGlobPattern] + -- ^ Files, references in which we should not analyze. + , ecIgnoreExternalRefsTo :: Field f [Regex] + -- ^ Regular expressions that match external references we should not verify. } deriving stock (Generic) -instance FromJSON (TraversalConfig' Maybe) where - parseJSON = genericParseJSON aesonConfigOption - -instance FromJSON (TraversalConfig) where - parseJSON = genericParseJSON aesonConfigOption - -normaliseTraversalConfigFilePaths :: TraversalConfig -> TraversalConfig -normaliseTraversalConfigFilePaths = TraversalConfig . map normaliseGlobPattern . tcIgnored +makeLensesWith postfixFields ''ExclusionConfig' -- | File extension, dot included. type Extension = String +-- | Whether the file is a symlink. +type IsSymlink = Bool + -- | Way to parse a file. -type ScanAction = FilePath -> IO (FileInfo, [ScanError]) +type ScanAction = FilePath -> RelPosixLink -> IO (FileInfo, [ScanError 'Parse]) -- | All supported ways to parse a file. -type FormatsSupport = Extension -> Maybe ScanAction +type FileSupport = IsSymlink -> Extension -> Maybe ScanAction data ScanResult = ScanResult - { srScanErrors :: [ScanError] + { srScanErrors :: [ScanError 'Gather] , srRepoInfo :: RepoInfo - } deriving stock (Show) + } -data ScanError = ScanError - { sePosition :: Position - , seFile :: FilePath +-- | A scan error indexed by different process stages. +-- +-- Within 'Parse', 'seFile' has no information because the same +-- file is being parsed. +-- +-- Within 'Gather', 'seFile' stores the 'FilePath' corresponding +-- to the file in where the error was found. +data ScanError (a :: ScanStage) = ScanError + { seFile :: ScanStageFile a + , sePosition :: Position , seDescription :: ScanErrorDescription - } deriving stock (Show, Eq) + } -instance Given ColorMode => Buildable ScanError where - build ScanError{..} = - "In file " +| styleIfNeeded Faint (styleIfNeeded Bold seFile) |+ "\n" - +| nameF ("scan error " +| sePosition |+ "") mempty |+ "\n⛀ " - +| seDescription |+ "\n\n\n" +data ScanStage = Parse | Gather +type family ScanStageFile (a :: ScanStage) where + ScanStageFile 'Parse = () + ScanStageFile 'Gather = RelPosixLink + +deriving stock instance Show (ScanError 'Parse) +deriving stock instance Show (ScanError 'Gather) +deriving stock instance Eq (ScanError 'Parse) +deriving stock instance Eq (ScanError 'Gather) + +-- | Make a 'ScanError' for the 'Parse' stage. +mkParseScanError :: Position -> ScanErrorDescription -> ScanError 'Parse +mkParseScanError = ScanError () + +-- | Promote a 'ScanError' from the 'Parse' stage +-- to the 'Gather' stage. +mkGatherScanError :: RelPosixLink -> ScanError 'Parse -> ScanError 'Gather +mkGatherScanError seFile ScanError{sePosition, seDescription} = ScanError + { seFile + , sePosition + , seDescription + } + +pprScanErr :: Given ColorMode => ScanError 'Gather -> Builder +pprScanErr ScanError{..} = hdr <> "\n" <> interpolateIndentF 2 msg <> "\n" + where + hdr, msg :: Builder + hdr = + styleIfNeeded Bold (build sePosition <> ": ") <> + colorIfNeeded Red "scan error:" + msg = build seDescription + +reportScanErrs :: Given ColorMode => NonEmpty (ScanError 'Gather) -> IO () +reportScanErrs errs = do + traverse_ (fmtLn . pprScanErr) errs + fmtLn $ colorIfNeeded Red $ + "Scan errors dumped, " <> build (length errs) <> " in total." + data ScanErrorDescription = LinkErr | FileErr @@ -91,84 +144,163 @@ instance Buildable ScanErrorDescription where build = \case - LinkErr -> "Expected a LINK after \"ignore link\" annotation" - FileErr -> "Annotation \"ignore file\" must be at the top of \ - \markdown or right after comments at the top" - ParagraphErr txt -> "Expected a PARAGRAPH after \ - \\"ignore paragraph\" annotation, but found " +| txt |+ "" - UnrecognisedErr txt -> "Unrecognised option \"" +| txt |+ "\" perhaps you meant \ - \<\"ignore link\"|\"ignore paragraph\"|\"ignore file\"> " + LinkErr -> [int||Expected a LINK after "ignore link" annotation|] + FileErr -> [int||Annotation "ignore all" must be at the top of \ + markdown or right after comments at the top|] + ParagraphErr txt -> [int||Expected a PARAGRAPH after \ + "ignore paragraph" annotation, but found #{txt}|] + UnrecognisedErr txt -> [int||Unrecognised option "#{txt}" + Perhaps you meant <"ignore link"|"ignore paragraph"|"ignore all">|] -specificFormatsSupport :: [([Extension], ScanAction)] -> FormatsSupport -specificFormatsSupport formats = \ext -> M.lookup ext formatsMap - where - formatsMap = M.fromList - [ (extension, parser) - | (extensions, parser) <- formats - , extension <- extensions - ] +firstFileSupport :: [FileSupport] -> FileSupport +firstFileSupport fs isSymlink = + safeHead . catMaybes <$> traverse ($ isSymlink) fs --- | Process files that are tracked by git and not ignored by the config. +data ReadDirectoryMode + = RdmTracked + -- ^ Consider files tracked by Git, obtained from "git ls-files" + | RdmUntracked + -- ^ Consider files that are not tracked nor ignored by Git, obtained from + -- "git ls-files --others --exclude-standard" + | RdmBothTrackedAndUtracked + -- ^ Combine output from commands listed above, so we consider all files + -- except ones that are explicitly ignored by Git + +-- | Process files that match given @ReadDirectoryMode@ and aren't ignored by the config. readDirectoryWith - :: forall a. TraversalConfig - -> (FilePath -> IO a) + :: forall a. ReadDirectoryMode + -> ExclusionConfig + -> (RelPosixLink -> IO a) -> FilePath - -> IO [(FilePath, a)] -readDirectoryWith config scanner root = - traverse scanFile - . filter (not . isIgnored) - . fmap (location ) - . L.lines =<< readCreateProcess (shell "git ls-files"){cwd = Just root} "" + -> IO [(RelPosixLink, a)] +readDirectoryWith mode config scanner root = do + relativeFiles <- fmap mkRelPosixLink . fileLines <$> getFiles + traverse scanFile $ filter (not . isIgnored) relativeFiles + where - scanFile :: FilePath -> IO (FilePath, a) - scanFile = sequence . (normaliseWithNoTrailing &&& scanner) - isIgnored :: FilePath -> Bool - isIgnored = matchesGlobPatterns root $ tcIgnored config + getFiles = case mode of + RdmTracked -> getTrackedFiles + RdmUntracked -> getUntrackedFiles + RdmBothTrackedAndUtracked -> liftA2 (<>) getTrackedFiles getUntrackedFiles - -- Strip leading "." and trailing "/" - location :: FilePath - location = - if root `equalFilePath` "." - then "" - else dropTrailingPathSeparator root + getTrackedFiles = readCreateProcess + (shell "git ls-files -z"){cwd = Just root} "" + getUntrackedFiles = readCreateProcess + (shell "git ls-files -z --others --exclude-standard"){cwd = Just root} "" + fileLines :: String -> [String] + fileLines (dropWhile (== '\0') -> ls) = + case break (== '\0') ls of + ([], _) -> [] + (f, ls') -> f : fileLines ls' + + scanFile :: RelPosixLink -> IO (RelPosixLink, a) + scanFile c = (c,) <$> scanner c + + isIgnored :: RelPosixLink -> Bool + isIgnored = matchesGlobPatterns (ecIgnore config) . canonicalizeRelPosixLink + scanRepo :: MonadIO m - => Rewrite -> FormatsSupport -> TraversalConfig -> FilePath -> m ScanResult -scanRepo rw formatsSupport config root = do + => ScanPolicy + -> Rewrite + -> FileSupport + -> ExclusionConfig + -> FilePath + -> m ScanResult +scanRepo scanMode rw formatsSupport config root = do putTextRewrite rw "Scanning repository..." - when (not $ isDirectory root) $ + liftIO $ whenM (not <$> doesDirectoryExist root) $ die $ "Repository's root does not seem to be a directory: " <> root - (errs, fileInfos) <- liftIO - $ (gatherScanErrs &&& gatherFileInfos) - <$> readDirectoryWith config processFile root + (errs, processedFiles) <- + let mode = case scanMode of + OnlyTracked -> RdmTracked + IncludeUntracked -> RdmBothTrackedAndUtracked + in liftIO $ (gatherScanErrs &&& gatherFileStatuses) + <$> readDirectoryWith mode config processFile root - let dirs = fromList $ foldMap (getDirs . fst) fileInfos + notProcessedFiles <- case scanMode of + OnlyTracked -> liftIO $ + readDirectoryWith RdmUntracked config (const $ pure NotAddedToGit) root + IncludeUntracked -> pure [] - return . ScanResult errs $ RepoInfo (M.fromList fileInfos) dirs - where - isDirectory :: FilePath -> Bool - isDirectory = readingSystem . doesDirectoryExist + scannableNotProcessedFiles <- liftIO $ + filterM (fmap isJust . fileScanner . fst) notProcessedFiles - -- Get all directories from filepath. - getDirs :: FilePath -> [FilePath] - getDirs = scanl () "" . splitDirectories . takeDirectory + whenJust (nonEmpty $ map fst scannableNotProcessedFiles) $ \files -> hPutStrLn @Text stderr + [int|A| + Those files are not added by Git, so we're not scanning them: + #{interpolateBlockListF files} + Please run "git add" before running xrefcheck or enable \ + --include-untracked CLI option to check these files. + |] + let trackedDirs = foldMap (getIntermediateDirs . fst) processedFiles + untrackedDirs = foldMap (getIntermediateDirs . fst) notProcessedFiles + + return . ScanResult errs $ RepoInfo + { riFiles = M.fromList $ fmap canonicalLinkEntry $ processedFiles <> notProcessedFiles + , riDirectories = M.fromList $ fmap canonicalLinkEntry (fmap (, TrackedDirectory) trackedDirs + <> fmap (, UntrackedDirectory) untrackedDirs) + } + where + fileScanner :: RelPosixLink -> IO (Maybe ScanAction) + fileScanner file = do + isSymlink <- pathIsSymbolicLink (filePathFromRoot root file) + pure $ formatsSupport isSymlink $ takeExtension file + gatherScanErrs - :: [(FilePath, Maybe (FileInfo, [ScanError]))] - -> [ScanError] - gatherScanErrs = fold . mapMaybe (fmap snd . snd) + :: [(RelPosixLink, (FileStatus, [ScanError 'Parse]))] + -> [ScanError 'Gather] + gatherScanErrs = foldMap $ \(file, (_, errs)) -> + mkGatherScanError file <$> errs - gatherFileInfos - :: [(FilePath, Maybe (FileInfo, [ScanError]))] - -> [(FilePath, Maybe FileInfo)] - gatherFileInfos = map (second (fmap fst)) + gatherFileStatuses + :: [(RelPosixLink, (FileStatus, [ScanError 'Parse]))] + -> [(RelPosixLink, FileStatus)] + gatherFileStatuses = map (second fst) - processFile :: FilePath -> IO $ Maybe (FileInfo, [ScanError]) + processFile :: RelPosixLink -> IO (FileStatus, [ScanError 'Parse]) processFile file = do - let ext = takeExtension file - let mscanner = formatsSupport ext - forM mscanner ($ file) + mScanner <- fileScanner file + case mScanner of + Nothing -> pure (NotScannable, []) + Just scanner -> scanner root file <&> _1 %~ Scanned + + canonicalLinkEntry + :: (RelPosixLink, a) + -> (CanonicalRelPosixLink, (RelPosixLink, a)) + canonicalLinkEntry (a, b) = (canonicalizeRelPosixLink a, (a, b)) + +----------------------------------------------------------- +-- Yaml instances +----------------------------------------------------------- + +instance FromJSON Regex where + parseJSON = withText "regex" $ \val -> do + let errOrRegex = R.compile defaultCompOption defaultExecOption val + either (error . show) return errOrRegex + +-- Default boolean values according to +-- https://hackage.haskell.org/package/regex-tdfa-1.3.1.0/docs/Text-Regex-TDFA.html#t:CompOption +defaultCompOption :: CompOption +defaultCompOption = CompOption + { caseSensitive = True + , multiline = True + , rightAssoc = True + , newSyntax = True + , lastStarGreedy = False + } + +-- ExecOption value to improve speed +defaultExecOption :: ExecOption +defaultExecOption = ExecOption {captureGroups = False} + +instance FromJSON (ExclusionConfig' Maybe) where + parseJSON = genericParseJSON aesonConfigOption + +instance FromJSON (ExclusionConfig) where + parseJSON = genericParseJSON aesonConfigOption diff --git a/src/Xrefcheck/Scanners/Markdown.hs b/src/Xrefcheck/Scanners/Markdown.hs --- a/src/Xrefcheck/Scanners/Markdown.hs +++ b/src/Xrefcheck/Scanners/Markdown.hs @@ -5,8 +5,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} --- | Markdown documents markdownScanner. - +-- | Scanner for gathering references to verify from Markdown documents. module Xrefcheck.Scanners.Markdown ( MarkdownConfig (..) @@ -17,22 +16,25 @@ , makeError ) where -import Universum +import Universum hiding (use) -import CMarkGFM (Node (..), NodeType (..), PosInfo (..), commonmarkToNode, optFootnotes) -import Control.Lens (_Just, makeLenses, makeLensesFor, (.=)) +import CMarkGFM + (Node (..), NodeType (..), PosInfo (..), commonmarkToNode, extAutolink, optFootnotes) +import Control.Lens (_Just, makeLenses, makeLensesFor, use, (.=)) import Control.Monad.Trans.Writer.CPS (Writer, runWriter, tell) import Data.Aeson (FromJSON (..), genericParseJSON) import Data.ByteString.Lazy qualified as BSL import Data.DList qualified as DList -import Data.Default (def) +import Data.Reflection (Given) import Data.Text qualified as T import Data.Text.Lazy qualified as LT -import Fmt (Buildable (..), blockListF, nameF, (+|), (|+)) +import Fmt (Buildable (..), nameF) import Text.HTML.TagSoup +import Text.Interpolation.Nyan import Xrefcheck.Core import Xrefcheck.Scan +import Xrefcheck.System import Xrefcheck.Util data MarkdownConfig = MarkdownConfig @@ -48,18 +50,21 @@ } instance Buildable Node where - build (Node _mpos ty subs) = nameF (show ty) $ blockListF subs + build (Node _mpos ty mSubs) = nameF (show ty) $ + maybe "[]" interpolateBlockListF (nonEmpty mSubs) -toPosition :: Maybe PosInfo -> Position -toPosition = Position . \case - Nothing -> Nothing +toPosition :: FilePath -> Maybe PosInfo -> Position +toPosition filepath = Position . \case + Nothing -> [int|s|#{filepath}|] Just PosInfo{..} - | startLine == endLine -> Just $ - startLine |+ ":" +| startColumn |+ "-" +| endColumn |+ "" - | otherwise -> Just $ - "" +| - startLine |+ ":" +| startColumn |+ " - " +| - endLine |+ ":" +| endColumn |+ "" + | startLine == endLine -> + [int|s| + #{filepath}:#{startLine}:#{startColumn}-#{endColumn} + |] + | otherwise -> + [int|s| + #{filepath}:#{startLine}:#{startColumn}-#{endLine}:#{endColumn} + |] -- | Extract text from the topmost node. nodeExtractText :: Node -> Text @@ -77,7 +82,7 @@ data IgnoreMode = IMLink | IMParagraph - | IMFile + | IMAll deriving stock (Eq) -- | "ignore link" pragmas in different places behave slightly different, @@ -102,7 +107,7 @@ data IgnoreModeState = IMSLink IgnoreLinkState | IMSParagraph - | IMSFile + | IMSAll deriving stock (Eq) -- | Bind `IgnoreMode` to its `PosInfo` so that we can tell where the @@ -119,8 +124,6 @@ | InvalidMode Text deriving stock (Eq) - - data ScannerState = ScannerState { _ssIgnore :: Maybe Ignore , _ssParentNodeType :: Maybe NodeType @@ -134,7 +137,7 @@ , _ssParentNodeType = Nothing } -type ScannerM a = StateT ScannerState (Writer [ScanError]) a +type ScannerM a = StateT ScannerState (Writer [ScanError 'Parse]) a -- | A fold over a `Node`. cataNode :: (Maybe PosInfo -> NodeType -> [c] -> c) -> Node -> c @@ -151,10 +154,11 @@ map (ssParentNodeType .= Just ty >>) childScanners -- | Find ignore annotations (ignore paragraph and ignore link) --- and remove nodes that should be ignored -removeIgnored :: FilePath -> Node -> Writer [ScanError] Node -removeIgnored fp = withIgnoreMode . cataNodeWithParentNodeInfo remove - where +-- and remove nodes that should be ignored. +removeIgnored :: Node -> ExtractorM Node +removeIgnored rootNode = do + filepath <- asks ecFilePath + let remove :: Maybe PosInfo -> NodeType @@ -165,31 +169,34 @@ scan <- use ssIgnore >>= \case -- When no `Ignore` state is set check next node for annotation, -- if found then set it as new `IgnoreMode` otherwise skip node. - Nothing -> handleIgnoreMode pos ty subs $ getIgnoreMode node + Nothing -> handleIgnoreMode pos ty subs $ getIgnoreMode node Just (Ignore mode modePos) -> case (mode, ty) of -- We expect to find a paragraph immediately after the -- `ignore paragraph` annotanion. If the paragraph is not -- found we should report an error. - (IMSParagraph, PARAGRAPH) -> (ssIgnore .= Nothing) $> defNode - (IMSParagraph, x) -> do - lift . tell . makeError modePos fp . ParagraphErr $ prettyType x + (IMSParagraph, PARAGRAPH) -> (ssIgnore .= Nothing) $> defNode + (IMSParagraph, x) -> do + lift . tell $ makeError filepath modePos (ParagraphErr (prettyType x)) ssIgnore .= Nothing Node pos ty <$> sequence subs - -- We don't expect to find an `ignore file` annotation here, + -- We don't expect to find an `ignore all` annotation here, -- since that annotation should be at the top of the file and -- the file should already be ignored when `checkIgnoreFile` is called. -- We should report an error if we find it anyway. - (IMSFile, _) -> do - lift . tell $ makeError modePos fp FileErr + (IMSAll, _) -> do + lift . tell $ makeError filepath modePos FileErr ssIgnore .= Nothing Node pos ty <$> sequence subs - (IMSLink _, LINK {}) -> do + (IMSLink _, LINK {}) -> do ssIgnore .= Nothing return defNode - (IMSLink ignoreLinkState, _) -> do + (IMSLink _, IMAGE {}) -> do + ssIgnore .= Nothing + return defNode + (IMSLink ignoreLinkState, _) -> do when (ignoreLinkState == ExpectingLinkInSubnodes) $ ssIgnore . _Just . ignoreMode .= IMSLink ParentExpectsLink node' <- Node pos ty <$> sequence subs @@ -197,14 +204,14 @@ currentIgnore <- use ssIgnore case currentIgnore of Just (Ignore {_ignoreMode = IMSLink ParentExpectsLink}) -> do - lift $ tell $ makeError modePos fp LinkErr + lift $ tell $ makeError filepath modePos LinkErr ssIgnore .= Nothing _ -> pass return node' when (ty == PARAGRAPH) $ use ssIgnore >>= \case Just (Ignore (IMSLink ExpectingLinkInParagraph) pragmaPos) -> - lift $ tell $ makeError pragmaPos fp LinkErr + lift $ tell $ makeError filepath pragmaPos LinkErr _ -> pass return scan @@ -224,11 +231,11 @@ IMParagraph -> pure IMSParagraph - IMFile -> pure IMSFile + IMAll -> pure IMSAll (ssIgnore .= Just (Ignore ignoreModeState correctPos)) $> defNode InvalidMode msg -> do - lift . tell $ makeError correctPos fp $ UnrecognisedErr msg + lift . tell $ makeError filepath correctPos $ UnrecognisedErr msg (ssIgnore .= Nothing) $> defNode NotAnAnnotation -> Node pos nodeType <$> sequence subs where @@ -239,24 +246,26 @@ let mType = safeHead $ words $ show ty in fromMaybe "" mType - withIgnoreMode - :: ScannerM Node - -> Writer [ScanError] Node - withIgnoreMode action = action `runStateT` initialScannerState >>= \case - -- We expect `Ignore` state to be `Nothing` when we reach EOF, - -- otherwise that means there was an annotation that didn't match - -- any node, so we have to report that. - (node, ScannerState {_ssIgnore = Just (Ignore mode pos)}) -> case mode of + action :: ScannerM Node + action = cataNodeWithParentNodeInfo remove rootNode + + (node, s) <- lift $ runStateT action initialScannerState + case s of + -- We expect `Ignore` state to be `Nothing` when we reach EOF, + -- otherwise that means there was an annotation that didn't match + -- any node, so we have to report that. + ScannerState {_ssIgnore = Just (Ignore mode pos)} -> do + case mode of IMSParagraph -> do - tell . makeError pos fp $ ParagraphErr "EOF" + lift $ tell . makeError filepath pos $ ParagraphErr "EOF" pure node IMSLink _ -> do - tell $ makeError pos fp LinkErr + lift $ tell $ makeError filepath pos LinkErr pure node - IMSFile -> do - tell $ makeError pos fp FileErr + IMSAll -> do + lift $ tell $ makeError filepath pos FileErr pure node - (node, _) -> pure node + _ -> pure node -- | Custom `foldMap` for source tree. foldNode :: (Monoid a, Monad m) => (Node -> m a) -> Node -> m a @@ -265,30 +274,33 @@ b <- concatForM subs (foldNode action) return (a <> b) -type ExtractorM a = ReaderT MarkdownConfig (Writer [ScanError]) a +data ExtractorCtx = ExtractorCtx + { ecConfig :: MarkdownConfig + , ecFilePath :: String -- for printing + } +type ExtractorM a = ReaderT ExtractorCtx (Writer [ScanError 'Parse]) a + -- | Extract information from source tree. -nodeExtractInfo - :: FilePath - -> Node - -> ExtractorM FileInfo -nodeExtractInfo fp input@(Node _ _ nSubs) = do - if checkIgnoreFile nSubs - then return def - else diffToFileInfo <$> (foldNode extractor =<< lift (removeIgnored fp input)) +nodeExtractInfo :: Node -> ExtractorM FileInfo +nodeExtractInfo input@(Node _ _ nSubs) = do + if checkIgnoreAllFile nSubs + then return (diffToFileInfo mempty) + else diffToFileInfo <$> (foldNode extractor =<< removeIgnored input) where extractor :: Node -> ExtractorM FileInfoDiff - extractor node@(Node pos ty _) = + extractor node@(Node pos ty _) = do + filepath <- asks ecFilePath case ty of HTML_BLOCK _ -> do return mempty HEADING lvl -> do - flavor <- asks mcFlavor + flavor <- asks (mcFlavor . ecConfig) let aType = HeaderAnchor lvl let aName = headerToAnchor flavor $ nodeExtractText node - let aPos = toPosition pos + let aPos = toPosition filepath pos return $ FileInfoDiff DList.empty $ DList.singleton $ Anchor {aType, aName, aPos} HTML_INLINE text -> do @@ -305,7 +317,7 @@ case mName of Just aName -> do let aType = HandAnchor - aPos = toPosition pos + aPos = toPosition filepath pos return $ FileInfoDiff mempty (pure $ Anchor {aType, aName, aPos}) @@ -313,24 +325,27 @@ Nothing -> do return mempty - LINK url _ -> do + LINK url _ -> extractLink url + + IMAGE url _ -> extractLink url + + _ -> return mempty + + where + extractLink url = do + filepath <- asks ecFilePath let rName = nodeExtractText node - rPos = toPosition pos - link = if null url then rName else url - let (rLink, rAnchor) = case T.splitOn "#" link of - [t] -> (t, Nothing) - t : ts -> (t, Just $ T.intercalate "#" ts) - [] -> error "impossible" + rPos = toPosition filepath pos + rInfo = referenceInfo $ if null url then rName else url + return $ FileInfoDiff - (DList.singleton $ Reference {rName, rPos, rLink, rAnchor}) + (DList.singleton $ Reference {rName, rPos, rInfo}) DList.empty - _ -> return mempty - --- | Check if there is `ignore file` at the beginning of the file, +-- | Check if there is `ignore all` at the beginning of the file, -- ignoring preceding comments if there are any. -checkIgnoreFile :: [Node] -> Bool -checkIgnoreFile nodes = +checkIgnoreAllFile :: [Node] -> Bool +checkIgnoreAllFile nodes = let isSimpleComment :: Node -> Bool isSimpleComment node = isComment node && not (isIgnoreFile node) @@ -341,17 +356,18 @@ isComment = isJust . getCommentContent isIgnoreFile :: Node -> Bool - isIgnoreFile = (ValidMode IMFile ==) . getIgnoreMode + isIgnoreFile = (ValidMode IMAll ==) . getIgnoreMode defNode :: Node defNode = Node Nothing DOCUMENT [] -- hard-coded default Node makeError - :: Maybe PosInfo - -> FilePath + :: FilePath + -> Maybe PosInfo -> ScanErrorDescription - -> [ScanError] -makeError pos fp errDescription = one $ ScanError (toPosition pos) fp errDescription + -> [ScanError 'Parse] +makeError filepath pos errDescription = + one $ mkParseScanError (toPosition filepath pos) errDescription getCommentContent :: Node -> Maybe Text getCommentContent node = do @@ -389,20 +405,28 @@ textToMode ("ignore" : [x]) | x == "link" = ValidMode IMLink | x == "paragraph" = ValidMode IMParagraph - | x == "file" = ValidMode IMFile + | x == "all" = ValidMode IMAll | otherwise = InvalidMode x textToMode _ = NotAnAnnotation -parseFileInfo :: MarkdownConfig -> FilePath -> LT.Text -> (FileInfo, [ScanError]) -parseFileInfo config fp input +parseFileInfo :: MarkdownConfig -> String -> LT.Text -> (FileInfo, [ScanError 'Parse]) +parseFileInfo config pathForPrinting input = runWriter - $ flip runReaderT config - $ nodeExtractInfo fp - $ commonmarkToNode [optFootnotes] [] + $ flip runReaderT (ExtractorCtx config pathForPrinting) + $ nodeExtractInfo + $ commonmarkToNode [optFootnotes] [extAutolink] $ toStrict input -markdownScanner :: MarkdownConfig -> ScanAction -markdownScanner config path = parseFileInfo config path . decodeUtf8 <$> BSL.readFile path +markdownScanner :: Given PrintUnixPaths => MarkdownConfig -> ScanAction +markdownScanner config root relativePath = + parseFileInfo config pathForPrinting . decodeUtf8 + <$> BSL.readFile rootedPath + where + rootedPath = filePathFromRoot root relativePath + pathForPrinting = mkPathForPrinting rootedPath -markdownSupport :: MarkdownConfig -> ([Extension], ScanAction) -markdownSupport config = ([".md"], markdownScanner config) +markdownSupport :: Given PrintUnixPaths => MarkdownConfig -> FileSupport +markdownSupport config isSymlink extension = do + guard $ extension == ".md" + guard $ not isSymlink + pure $ markdownScanner config diff --git a/src/Xrefcheck/Scanners/Symlink.hs b/src/Xrefcheck/Scanners/Symlink.hs new file mode 100644 --- /dev/null +++ b/src/Xrefcheck/Scanners/Symlink.hs @@ -0,0 +1,39 @@ +{- SPDX-FileCopyrightText: 2023 Serokell + - + - SPDX-License-Identifier: MPL-2.0 + -} + +-- | Scanner for gathering references to verify from symlinks. +-- +-- A symlink's reference corresponds to the file it points to. +module Xrefcheck.Scanners.Symlink + ( symlinkScanner + , symlinkSupport + ) where + +import Universum + +import Data.Reflection (Given) +import System.Directory (getSymbolicLinkTarget) + +import Xrefcheck.Core +import Xrefcheck.Scan +import Xrefcheck.System + +symlinkScanner :: Given PrintUnixPaths => ScanAction +symlinkScanner root relativePath = do + let rootedPath = filePathFromRoot root relativePath + pathForPrinting = mkPathForPrinting rootedPath + rLink <- unRelPosixLink . mkRelPosixLink + <$> getSymbolicLinkTarget rootedPath + + let rName = "Symbolic Link" + rPos = Position (fromString pathForPrinting) + rInfo = referenceInfo rLink + + pure (FileInfo [Reference {rName, rPos, rInfo}] [], []) + +symlinkSupport :: Given PrintUnixPaths => FileSupport +symlinkSupport isSymlink _ = do + guard isSymlink + pure symlinkScanner diff --git a/src/Xrefcheck/System.hs b/src/Xrefcheck/System.hs --- a/src/Xrefcheck/System.hs +++ b/src/Xrefcheck/System.hs @@ -4,86 +4,261 @@ -} module Xrefcheck.System - ( readingSystem - , askWithinCI - , RelGlobPattern - , mkGlobPattern - , normaliseGlobPattern - , bindGlobPattern + ( askWithinCI + + , RelPosixLink (..) + , () + , mkRelPosixLink + , filePathFromRoot + , getIntermediateDirs + , hasBackslash + , takeDirectory + , takeExtension + + , CanonicalRelPosixLink (unCanonicalRelPosixLink) + , hasUnexpanededParentIndirections + , canonicalizeRelPosixLink + + , CanonicalRelGlobPattern (unCanonicalRelGlobPattern) , matchesGlobPatterns + , mkCanonicalRelGlobPattern + + , PrintUnixPaths(..) + , mkPathForPrinting ) where import Universum import Data.Aeson (FromJSON (..), withText) import Data.Char qualified as C -import Data.Coerce (coerce) -import GHC.IO.Unsafe (unsafePerformIO) -import System.Directory (canonicalizePath) +import Data.Reflection (Given (..)) +import Data.Text qualified as T +import Fmt (Buildable) +import System.Console.Pretty (Pretty) import System.Environment (lookupEnv) -import System.FilePath (isRelative, ()) -import System.FilePath.Glob (CompOptions (errorRecovery)) +import System.FilePath qualified as FP import System.FilePath.Glob qualified as Glob -import Xrefcheck.Util (normaliseWithNoTrailing) - --- | We can quite safely treat surrounding filesystem as frozen, --- so IO reading operations can be turned into pure values. -readingSystem :: IO a -> a -readingSystem = unsafePerformIO +import System.FilePath.Posix qualified as FPP +import Text.Interpolation.Nyan (int, rmode') -- | Heuristics to check whether we are running within CI. -- Check the respective env variable which is usually set in all CIs. askWithinCI :: IO Bool askWithinCI = lookupEnv "CI" <&> \case - Just "1" -> True + Just "1" -> True Just (map C.toLower -> "true") -> True - _ -> False + _ -> False --- | Glob pattern relative to repository root. Should be created via @mkGlobPattern@ -newtype RelGlobPattern = RelGlobPattern FilePath +-- | Relative file path with POSIX path separators. +-- +-- This type exist in contrast to 'FilePath' which, in this project, +-- is used for platform-dependent file paths and related filesystem +-- IO operations. +-- +-- Note that `RelPosixLink` may contain `\` characters, but they are +-- considered as part of the filename instead of denoting a path +-- separator. +newtype RelPosixLink = RelPosixLink + { unRelPosixLink :: Text + } deriving newtype (Show, Eq, Ord, NFData, Buildable, Pretty) -mkGlobPattern :: ToString s => s -> Either String RelGlobPattern -mkGlobPattern path = do +-- | Create a POSIX file path from a platform-dependent one. +mkRelPosixLink :: FilePath -> RelPosixLink +mkRelPosixLink = RelPosixLink + . withPathSeparator FPP.pathSeparator + . fromString + +-- | Join two 'RelPosixLink's. +() :: RelPosixLink -> RelPosixLink -> RelPosixLink +RelPosixLink a RelPosixLink b = + let a' = fromMaybe a $ T.stripSuffix "/" a + b' = fromMaybe b $ T.stripPrefix "./" a + in case (a', b') of + ("", _) -> RelPosixLink b + (".", _) -> RelPosixLink b + _ -> RelPosixLink $ a' <> "/" <> b' + +-- Get the platform-dependent file path from a 'RelPosixLink' +-- considered as relative to another given platform-dependent +-- 'FilePath'. +-- +-- In Windows, every `\` occurrence will be replaced by `/`. +filePathFromRoot :: FilePath -> RelPosixLink -> FilePath +filePathFromRoot rootPath = (rootPath FP.) + . toString + . withPathSeparator FP.pathSeparator + . unRelPosixLink + +-- | 'FilePath.takeDirectory' version for 'RelPosixLink'. +takeDirectory :: RelPosixLink -> RelPosixLink +takeDirectory = RelPosixLink + . fromString + . FPP.takeDirectory + . toString + . unRelPosixLink + +-- | 'FilePath.takeExtension' version for 'RelPosixLink'. +takeExtension :: RelPosixLink -> String +takeExtension = FPP.takeExtension + . toString + . unRelPosixLink + +-- | 'Check if a 'RelPosixLink' contains any backslash. +hasBackslash :: RelPosixLink -> Bool +hasBackslash = ('\\' `elem`) + . unRelPosixLink + +-- | Get the list of directories between a 'RelPosixLink' and its +-- relative root. +getIntermediateDirs :: RelPosixLink -> [RelPosixLink] +getIntermediateDirs link = fmap RelPosixLink $ + case T.splitOn "/" $ unRelPosixLink $ takeDirectory link of + [] -> [] + ["."] -> [""] + [".."] -> ["", ".."] + d : ds -> scanl (\a b -> a <> "/" <> b) d ds + +-- | Relative POSIX file path with some normalizations applied. +-- +-- It should be created from a 'RelPosixLink' via +-- 'canonicalizeRelPosixLink'. +newtype CanonicalRelPosixLink = UnsafeCanonicalRelPosixLink + { unCanonicalRelPosixLink :: RelPosixLink + } deriving newtype (Show, Eq, Ord, NFData, Buildable, Pretty) + +-- | Canonicalize a 'RelPosixLink'. +-- +-- Applies the following normalizations: +-- +-- * Drop trailing path separator. +-- +-- * Expand '.' and '..' indirections syntactically. +-- +canonicalizeRelPosixLink :: RelPosixLink -> CanonicalRelPosixLink +canonicalizeRelPosixLink = UnsafeCanonicalRelPosixLink + . RelPosixLink + . expandPosixIndirections + . dropTrailingPosixPathSeparator + . withPathSeparator FPP.pathSeparator + . unRelPosixLink + +-- | Check if a 'CanonicalRelPosixLink' passes through its relative root when +-- expanding indirections. +hasUnexpanededParentIndirections :: CanonicalRelPosixLink -> Bool +hasUnexpanededParentIndirections = elem ".." + . T.splitOn "/" + . unRelPosixLink + . unCanonicalRelPosixLink + +-- | Relative Glob pattern with some normalizations applied. +-- +-- It should be created via 'mkCanonicalRelGlobPattern'. +newtype CanonicalRelGlobPattern = UnsafeCanonicalRelGlobPattern + { unCanonicalRelGlobPattern :: Glob.Pattern + } + +-- | Create a CanonicalRelGlobPattern from a 'ToString' instance value that +-- represents a POSIX glob pattern. +-- +-- Applies the following normalizations: +-- +-- * Drop trailing path separator. +-- +-- * FilePath.Posix.normalise. +-- +-- * Expand '.' and '..' indirections syntactically. +-- +mkCanonicalRelGlobPattern :: ToString s => s -> Either String CanonicalRelGlobPattern +mkCanonicalRelGlobPattern path = do let spath = toString path - unless (isRelative spath) $ Left $ + unless (FPP.isRelative spath) $ Left $ "Expected a relative glob pattern, but got " <> spath -- Checking correctness of glob, e.g. "a[b" is incorrect - case Glob.tryCompileWith globCompileOptions spath of - Right _ -> return (RelGlobPattern spath) + case Glob.tryCompileWith globCompileOptions (normalise spath) of + Right pat -> return $ UnsafeCanonicalRelGlobPattern pat Left err -> Left - $ "Glob pattern compilation failed.\n" - <> "Error message is:\n" - <> err - <> "\nThe syntax for glob patterns is described here:\n" - <> "https://hackage.haskell.org/package/Glob/docs/System-FilePath-Glob.html#v:compile" - <> "\nSpecial characters in file names can be escaped using square brackets" - <> ", e.g. -> [<]a[>]." - -normaliseGlobPattern :: RelGlobPattern -> RelGlobPattern -normaliseGlobPattern = RelGlobPattern . normaliseWithNoTrailing . coerce - -bindGlobPattern :: FilePath -> RelGlobPattern -> Glob.Pattern -bindGlobPattern root (RelGlobPattern relPat) = readingSystem $ do - -- TODO [#26] try to avoid using canonicalization - absPat <- canonicalizePath (root relPat) - case Glob.tryCompileWith globCompileOptions absPat of - Left err -> error $ - "Glob pattern compilation failed after canonicalization: " <> toText err - Right pat -> - return pat + [int|| + Glob pattern compilation failed. + Error message is: + #{err} + The syntax for glob patterns is described here: + https://hackage.haskell.org/package/Glob/docs/System-FilePath-Glob.html#v:compile + Special characters in file names can be escaped using square brackets, e.g. -> [<]a[>]. + |] + where + normalise = toString + . expandPosixIndirections + . fromString + . FPP.normalise + . FPP.dropTrailingPathSeparator -matchesGlobPatterns :: FilePath -> [RelGlobPattern] -> FilePath -> Bool -matchesGlobPatterns root globPatterns file = or - [ Glob.match pat cFile - | globPattern <- globPatterns - , let pat = bindGlobPattern root globPattern - , let cFile = readingSystem $ canonicalizePath file +-- Checks if a 'CanonicalRelPosixLink' matches some of the given +-- 'CanonicalRelGlobPattern's. +-- +-- They are considered as relative to the same root. +matchesGlobPatterns :: [CanonicalRelGlobPattern] -> CanonicalRelPosixLink -> Bool +matchesGlobPatterns globPatterns file = or + [ Glob.match pat . toString . unRelPosixLink . unCanonicalRelPosixLink $ file + | UnsafeCanonicalRelGlobPattern pat <- globPatterns ] -instance FromJSON RelGlobPattern where +instance FromJSON CanonicalRelGlobPattern where parseJSON = withText "Repo-relative glob pattern" $ - either fail pure . mkGlobPattern + either fail pure . mkCanonicalRelGlobPattern -- | Glob compilation options we use. globCompileOptions :: Glob.CompOptions -globCompileOptions = Glob.compDefault{errorRecovery = False} +globCompileOptions = Glob.compDefault{Glob.errorRecovery = False} + +dropTrailingPosixPathSeparator :: Text -> Text +dropTrailingPosixPathSeparator p = fromMaybe p + $ T.stripSuffix "/" p + +-- Expand '.' and '..' in paths with Posix path separators. +expandPosixIndirections :: Text -> Text +expandPosixIndirections = T.intercalate "/" + . reverse + . expand 0 + . reverse + . T.split (FPP.isPathSeparator) + where + expand :: Int -> [Text] -> [Text] + expand acc (".." : xs) = expand (acc + 1) xs + expand acc ("." : xs) = expand acc xs + expand 0 (x : xs) = x : expand 0 xs + expand acc (_ : xs) = expand (acc - 1) xs + expand acc [] = replicate acc ".." + +-- Expand '.' and '..' in paths with system-specific path separators. +expandPathIndirections :: FilePath -> FilePath +expandPathIndirections = FP.joinPath + . reverse + . expand 0 + . reverse + . map FP.dropTrailingPathSeparator + . FP.splitPath + where + expand :: Int -> [FilePath] -> [FilePath] + expand acc (".." : xs) = expand (acc + 1) xs + expand acc ("." : xs) = expand acc xs + expand 0 (x : xs) = x : expand 0 xs + expand acc (_ : xs) = expand (acc - 1) xs + expand acc [] = replicate acc ".." + +withPathSeparator :: Char -> Text -> Text +withPathSeparator pathSep = T.map replaceSeparator + where + replaceSeparator :: Char -> Char + replaceSeparator c + | FP.isPathSeparator c = pathSep + | otherwise = c + +newtype PrintUnixPaths = PrintUnixPaths Bool + +mkPathForPrinting :: Given PrintUnixPaths => FilePath -> String +mkPathForPrinting = replaceSeparator . expandPathIndirections + where + replaceSeparator :: FilePath -> String + replaceSeparator = case given of + PrintUnixPaths True -> map (\c -> if c == FP.pathSeparator then '/' else c) + PrintUnixPaths False -> id diff --git a/src/Xrefcheck/Util.hs b/src/Xrefcheck/Util.hs --- a/src/Xrefcheck/Util.hs +++ b/src/Xrefcheck/Util.hs @@ -9,15 +9,17 @@ , postfixFields , (-:) , aesonConfigOption - , normaliseWithNoTrailing + , doesMatchAnyRegex , posixTimeToTimeSecond , utcTimeToTimeSecond + , module Xrefcheck.Util.Colorize + , module Xrefcheck.Util.Interpolate ) where -import Universum +import Universum hiding ((.~)) -import Control.Lens (LensRules, lensField, lensRules, mappingNamer) +import Control.Lens (LensRules, lensField, lensRules, mappingNamer, (.~)) import Data.Aeson qualified as Aeson import Data.Aeson.Casing (aesonPrefix, camelCase) import Data.Fixed (Fixed (MkFixed), HasResolution (resolution)) @@ -26,10 +28,11 @@ import Data.Time.Clock (nominalDiffTimeToSeconds) import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds) import Fmt (Builder) -import System.FilePath (dropTrailingPathSeparator, normalise) +import Text.Regex.TDFA.Text (Regex, regexec) import Time (Second, Time (..), sec) import Xrefcheck.Util.Colorize +import Xrefcheck.Util.Interpolate paren :: Builder -> Builder paren a @@ -52,9 +55,6 @@ Field Identity a = a Field Maybe a = Maybe a -normaliseWithNoTrailing :: FilePath -> FilePath -normaliseWithNoTrailing = dropTrailingPathSeparator . normalise - posixTimeToTimeSecond :: POSIXTime -> Time Second posixTimeToTimeSecond posixTime = let picos@(MkFixed ps) = nominalDiffTimeToSeconds posixTime @@ -62,3 +62,12 @@ utcTimeToTimeSecond :: UTCTime -> Time Second utcTimeToTimeSecond = posixTimeToTimeSecond . utcTimeToPOSIXSeconds + +doesMatchAnyRegex :: Text -> ([Regex] -> Bool) +doesMatchAnyRegex src = any $ \regex -> + case regexec regex src of + Right res -> case res of + Just (before, match, after, _) -> + null before && null after && not (null match) + Nothing -> False + Left _ -> False diff --git a/src/Xrefcheck/Util/Interpolate.hs b/src/Xrefcheck/Util/Interpolate.hs new file mode 100644 --- /dev/null +++ b/src/Xrefcheck/Util/Interpolate.hs @@ -0,0 +1,86 @@ +{- SPDX-FileCopyrightText: 2018-2019 Serokell + - + - SPDX-License-Identifier: MPL-2.0 + -} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +module Xrefcheck.Util.Interpolate + ( -- $notes + interpolateIndentF + , interpolateBlockListF + , interpolateBlockListF' + , interpolateUnlinesF + ) + where + +import Universum + +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Builder (fromLazyText, toLazyText) +import Fmt (Buildable, Builder, blockListF, blockListF', indentF, unlinesF) + +{- $notes +The `blockListF` and `indentF` frunctions from @fmt@ add a trailing newline, which makes them unsuitable for string interpolation. +Consider this case: +> [int|| +> aaa +> #{indentF 2 "bbb"} +> ccc +> |] +One would reasonably expect this to produce: +> aaa +> bbb +> ccc +But, in reality, it produces: +> aaa +> bbb +> +> ccc +This module introduces versions of these functions that do not produce a trailing newline +and can therefore be safely used in string interpolation. +-} + +{-# HLINT ignore "Avoid functions that generate extra trailing newlines/whitespaces" #-} + +-- | Like @Fmt.indentF@, but strips trailing spaces and does not add a trailing newline. +-- +-- >>> import Fmt +-- >>> indentF 2 "a\n\nb" +-- " a\n \n b\n" +-- +-- >>> interpolateIndentF 2 "a\n\nb" +-- " a\n\n b" +interpolateIndentF :: HasCallStack => Int -> Builder -> Builder +interpolateIndentF n b = (case TL.last (toLazyText b) of + '\n' -> id + _ -> stripLastNewline) $ stripTrailingSpaces $ indentF n b + -- strips newline added by indentF + +-- | Like @Fmt.blockListF'@, but strips trailing spaces and does not add a trailing newline. +interpolateBlockListF' :: HasCallStack => Text -> (a -> Builder) -> NonEmpty a -> Builder +interpolateBlockListF' = stripLastNewline . stripTrailingSpaces ... blockListF' + +-- | Like @Fmt.blockListF@, but strips trailing spaces and does not add a trailing newline. +interpolateBlockListF :: HasCallStack => Buildable a => NonEmpty a -> Builder +interpolateBlockListF = stripLastNewline . stripTrailingSpaces . blockListF + +-- | Like @Fmt.unlinesF@, but strips trailing spaces and does not add a trailing newline. +interpolateUnlinesF :: HasCallStack => Buildable a => NonEmpty a -> Builder +interpolateUnlinesF = stripLastNewline . stripTrailingSpaces . unlinesF + +-- remove trailing whitespace from all lines. +-- Note: output always ends with newline (adds trailing newline if there wasn't one). +stripTrailingSpaces :: Builder -> Builder +stripTrailingSpaces + = fromLazyText + . TL.unlines + . map (TL.stripEnd) + . TL.lines + . toLazyText + +stripLastNewline :: HasCallStack => Builder -> Builder +stripLastNewline + = fromLazyText + . fromMaybe (error "stripLastNewline: expected newline to strip") + . TL.stripSuffix "\n" + . toLazyText diff --git a/src/Xrefcheck/Verify.hs b/src/Xrefcheck/Verify.hs --- a/src/Xrefcheck/Verify.hs +++ b/src/Xrefcheck/Verify.hs @@ -5,12 +5,10 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE PartialTypeSignatures #-} -{-# OPTIONS_GHC -Wno-partial-type-signatures #-} module Xrefcheck.Verify ( -- * General verification VerifyResult (..) - , verifyOk , verifyErrors , verifying @@ -22,54 +20,59 @@ , forConcurrentlyCaching -- * Cross-references validation + , DomainName (..) , VerifyError (..) , verifyRepo , verifyReference , checkExternalResource - - -- * URI parsing - , parseUri + , reportVerifyErrs ) where import Universum -import Control.Concurrent.Async (async, wait, withAsync) -import Control.Exception (throwIO) -import Control.Monad.Catch (handleJust) +import Control.Concurrent.Async (Async, async, cancel, poll, wait, withAsync) +import Control.Exception (AsyncException (..), throwIO) +import Control.Exception.Safe (handleAsync) import Control.Monad.Except (MonadError (..)) +import Data.Bits (toIntegralSized) import Data.ByteString qualified as BS +import Data.List (lookup) import Data.List qualified as L import Data.Map qualified as M import Data.Reflection (Given) +import Data.Set qualified as S +import Data.Text (toCaseFold) import Data.Text.Metrics (damerauLevenshteinNorm) import Data.Time (UTCTime, defaultTimeLocale, formatTime, readPTime, rfc822DateFormat) import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Traversable (for) -import Fmt (Buildable (..), blockListF', indentF, listF, maybeF, nameF, unlinesF, (+|), (|+)) +import Fmt (Buildable (..), Builder, fmt, fmtLn, maybeF, nameF) import GHC.Exts qualified as Exts import GHC.Read (Read (readPrec)) +import Network.Connection qualified as N.C import Network.FTP.Client (FTPException (..), FTPResponse (..), ResponseStatus (..), login, nlst, size, withFTP, withFTPS) import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), Response, responseHeaders, responseStatus) import Network.HTTP.Req - (AllowsBody, CanHaveBody (NoBody), GET (..), HEAD (..), HttpBodyAllowed, HttpException (..), - HttpMethod, NoReqBody (..), defaultHttpConfig, ignoreResponse, req, runReq, useURI) + (AllowsBody, CanHaveBody (NoBody), GET (..), HEAD (..), HttpBodyAllowed, + HttpConfig (httpConfigRedirectCount), HttpException (..), HttpMethod, NoReqBody (..), + defaultHttpConfig, ignoreResponse, req, runReq, useURI) import Network.HTTP.Types.Header (hRetryAfter) import Network.HTTP.Types.Status (Status, statusCode, statusMessage) -import System.FilePath - (equalFilePath, joinPath, makeRelative, normalise, splitDirectories, takeDirectory, ()) +import Text.Interpolation.Nyan import Text.ParserCombinators.ReadPrec qualified as ReadPrec (lift) -import Text.Regex.TDFA.Text (Regex, regexec) -import Text.URI (Authority (..), ParseExceptionBs, URI (..), mkURIBs) +import Text.URI (Authority (..), URI (..), relativeTo, render, unRText) import Time (RatioNat, Second, Time (..), ms, sec, threadDelay, timeout, (+:+), (-:-)) -import URI.ByteString qualified as URIBS -import Data.Bits (toIntegralSized) +import Control.Monad.Trans.Except (withExceptT) import Xrefcheck.Config import Xrefcheck.Core +import Xrefcheck.Data.URI import Xrefcheck.Orphans () import Xrefcheck.Progress +import Xrefcheck.Scan +import Xrefcheck.Scanners.Markdown (MarkdownConfig (mcFlavor)) import Xrefcheck.System import Xrefcheck.Util @@ -86,12 +89,6 @@ deriving newtype instance Semigroup (VerifyResult e) deriving newtype instance Monoid (VerifyResult e) -instance Buildable e => Buildable (VerifyResult e) where - build vr = maybe "ok" listF (verifyErrors vr) - -verifyOk :: VerifyResult e -> Bool -verifyOk (VerifyResult errors) = null errors - verifyErrors :: VerifyResult e -> Maybe (NonEmpty e) verifyErrors (VerifyResult errors) = nonEmpty errors @@ -106,97 +103,254 @@ ----------------------------------------------------------- data WithReferenceLoc a = WithReferenceLoc - { wrlFile :: FilePath + { wrlFile :: RelPosixLink , wrlReference :: Reference , wrlItem :: a } -instance (Given ColorMode, Buildable a) => Buildable (WithReferenceLoc a) where - build WithReferenceLoc{..} = - "In file " +| styleIfNeeded Faint (styleIfNeeded Bold wrlFile) |+ "\nbad " - +| wrlReference |+ "\n" - +| wrlItem |+ "\n\n" +-- | Contains a name of a domain, examples: +-- @DomainName "github.com"@, +-- @DomainName "localhost"@, +-- @DomainName "192.168.0.104"@ +newtype DomainName = DomainName { unDomainName :: Text } + deriving stock (Show, Eq, Ord) data VerifyError - = LocalFileDoesNotExist FilePath - | LocalFileOutsideRepo FilePath + = LocalFileDoesNotExist RelPosixLink + | LocalFileOutsideRepo RelPosixLink + | LinkTargetNotAddedToGit RelPosixLink | AnchorDoesNotExist Text [Anchor] - | AmbiguousAnchorRef FilePath Text (NonEmpty Anchor) - | ExternalResourceInvalidUri URIBS.URIParseError - | ExternalResourceUriConversionError ParseExceptionBs + | AmbiguousAnchorRef RelPosixLink Text (NonEmpty Anchor) + | ExternalResourceUriParseError UriParseError | ExternalResourceInvalidUrl (Maybe Text) | ExternalResourceUnknownProtocol | ExternalHttpResourceUnavailable Status - | ExternalHttpTooManyRequests (Maybe RetryAfter) + | ExternalHttpTooManyRequests (Maybe RetryAfter) (Maybe DomainName) + | ExternalHttpTimeout (Maybe DomainName) | ExternalFtpResourceUnavailable FTPResponse | ExternalFtpException FTPException | FtpEntryDoesNotExist FilePath | ExternalResourceSomeError Text + | ExternalResourceConnectionFailure + | RedirectChainCycle RedirectChain + | RedirectMissingLocation RedirectChain + | RedirectChainLimit RedirectChain + | RedirectRuleError RedirectChain (Maybe RedirectRuleOn) deriving stock (Show, Eq) -instance Given ColorMode => Buildable VerifyError where - build = \case +data ResponseResult + = RRDone + | RRFollow Text + +pprVerifyErr' :: Given ColorMode => ReferenceInfo -> VerifyError -> Builder +pprVerifyErr' rInfo = \case LocalFileDoesNotExist file -> - "⛀ File does not exist:\n " +| file |+ "\n" + [int|| + File does not exist: + #{file}#l{ + if hasBackslash file + then "\\n Its reference contains a backslash. Maybe it uses the wrong path separator." + else "" + } + |] LocalFileOutsideRepo file -> - "⛀ Link targets a local file outside repository:\n " +| file |+ "\n" + [int|| + Link #{pprLinkTyp rInfo} targets a local file outside the repository: + #{file} + |] - AnchorDoesNotExist anchor similar -> - "⛀ Anchor '" +| anchor |+ "' is not present" +| - anchorHints similar + LinkTargetNotAddedToGit file -> + [int|| + Link #{pprLinkTyp rInfo} targets a file not tracked by Git: + #{file} + Please run "git add" before running xrefcheck or enable --include-untracked CLI option. + |] + AnchorDoesNotExist anchor similar -> case nonEmpty similar of + Nothing -> + [int|| + Anchor '#{anchor}' is not present + |] + Just otherAnchors -> + [int|| + Anchor '#{anchor}' is not present, did you mean: + #{interpolateIndentF 2 $ interpolateBlockListF otherAnchors} + |] + AmbiguousAnchorRef file anchor fileAnchors -> - "⛀ Ambiguous reference to anchor '" +| anchor |+ "'\n " +| - "In file " +| file |+ "\n " +| - "Similar anchors are:\n" +| - blockListF' " -" build fileAnchors |+ "" +| - " Use of such anchors is discouraged because referenced object\n\ - \ can change silently whereas the document containing it evolves.\n" + [int|| + Ambiguous reference to anchor '#{anchor}' + in file #{file} + It could refer to either: + #{interpolateIndentF 2 $ interpolateBlockListF fileAnchors} + Use of ambiguous anchors is discouraged because the target + can change silently while the document containing it evolves. + |] - ExternalResourceInvalidUri err -> - "⛂ Invalid URI (" +| err |+ ")\n" + ExternalResourceUriParseError (UPEInvalid err) -> + [int|| + Invalid URI (#{err}) + |] <> pprLinkCtx rInfo - ExternalResourceUriConversionError err -> - unlinesF - [ "⛂ Invalid URI" - , indentF 4 . build $ displayException err - ] + ExternalResourceUriParseError (UPEConversion err) -> + [int|| + Invalid URI + #{interpolateIndentF 2 . build $ displayException err} + |] <> pprLinkCtx rInfo ExternalResourceInvalidUrl Nothing -> - "⛂ Invalid URL\n" + [int|| + Invalid URL + |] <> pprLinkCtx rInfo ExternalResourceInvalidUrl (Just message) -> - "⛂ Invalid URL (" +| message |+ ")\n" + [int|| + Invalid URL (#{message}) + |] <> pprLinkCtx rInfo ExternalResourceUnknownProtocol -> - "⛂ Bad url (expected 'http','https', 'ftp' or 'ftps')\n" + [int|| + Bad url (expected 'http','https', 'ftp' or 'ftps') + |] <> pprLinkCtx rInfo ExternalHttpResourceUnavailable status -> - "⛂ Resource unavailable (" +| statusCode status |+ " " +| - decodeUtf8 @Text (statusMessage status) |+ ")\n" + [int|| + Resource unavailable (#{statusCode status} #{decodeUtf8 @Text (statusMessage status)}) + |] <> pprLinkCtx rInfo - ExternalHttpTooManyRequests retryAfter -> - "⛂ Resource unavailable (429 Too Many Requests; retry after " +| - maybeF retryAfter |+ ")\n" + ExternalHttpTooManyRequests retryAfter _ -> + [int|| + Resource unavailable (429 Too Many Requests; retry after #{maybeF retryAfter}) + |] <> pprLinkCtx rInfo + ExternalHttpTimeout _ -> + [int|| + Response timeout + |] <> pprLinkCtx rInfo + ExternalFtpResourceUnavailable response -> - "⛂ Resource unavailable:\n" +| response |+ "\n" + [int|| + Resource unavailable: + #{response} + |] <> pprLinkCtx rInfo ExternalFtpException err -> - "⛂ FTP exception (" +| err |+ ")\n" + [int|| + FTP exception (#{err}) + |] <> pprLinkCtx rInfo FtpEntryDoesNotExist entry -> - "⛂ File or directory does not exist:\n" +| entry |+ "\n" + [int|| + File or directory does not exist: + #{entry} + |] ExternalResourceSomeError err -> - "⛂ " +| build err |+ "\n\n" - where - anchorHints = \case - [] -> "\n" - [h] -> ",\n did you mean " +| h |+ "?\n" - hs -> ", did you mean:\n" +| blockListF' " -" build hs + [int|| + #{err} + |] <> pprLinkCtx rInfo + ExternalResourceConnectionFailure -> + [int|| + Connection failure + |] <> pprLinkCtx rInfo + + RedirectChainCycle chain -> + [int|| + Cycle found in the following redirect chain: + #{interpolateIndentF 2 $ attachToRedirectChain chain "here"} + |] <> pprLinkCtx rInfo + + RedirectMissingLocation chain -> + [int|| + Missing location header in the following redirect chain: + #{interpolateIndentF 2 $ attachToRedirectChain chain "no location header"} + |] <> pprLinkCtx rInfo + + RedirectChainLimit chain -> + [int|| + The follow redirects limit has been reached in the following redirect chain: + #{interpolateIndentF 2 $ attachToRedirectChain chain "stopped before this one"} + |] <> pprLinkCtx rInfo + + RedirectRuleError chain mOn -> + [int|| + #{redirect} found: + #{interpolateIndentF 2 $ attachToRedirectChain chain "stopped before this one"} + |] <> pprLinkCtx rInfo + where + redirect :: Text + redirect = case mOn of + Nothing -> "Redirect" + Just RROPermanent -> "Permanent redirect" + Just RROTemporary -> "Temporary redirect" + Just (RROCode code) -> show code <> " redirect" + +attachToRedirectChain :: RedirectChain -> Text -> Builder +attachToRedirectChain chain attached + = build chain <> build attachedText + where + attachedText = "\n ^-- " <> attached + +data RetryCounter = RetryCounter + { rcTotalRetries :: Int + , rcTimeoutRetries :: Int + } deriving stock (Show) + +incTotalCounter :: RetryCounter -> RetryCounter +incTotalCounter rc = rc {rcTotalRetries = rcTotalRetries rc + 1} + +incTimeoutCounter :: RetryCounter -> RetryCounter +incTimeoutCounter rc = rc {rcTimeoutRetries = rcTimeoutRetries rc + 1} + +pprVerifyErr :: Given ColorMode => WithReferenceLoc VerifyError -> Builder +pprVerifyErr wrl = hdr <> "\n" <> interpolateIndentF 2 msg + where + WithReferenceLoc{wrlReference, wrlItem} = wrl + Reference{rName, rInfo} = wrlReference + + hdr, msg :: Builder + hdr = + styleIfNeeded Bold (build (rPos wrlReference) <> ": ") <> + colorIfNeeded Red "bad reference:" + msg = + "The reference to " <> show rName <> " failed verification.\n" <> + pprVerifyErr' rInfo wrlItem + +pprLink :: Given ColorMode => ReferenceInfo -> Maybe (Builder, Builder) +pprLink = \case + RIFile ReferenceInfoFile{..} -> + case rifLink of + FLLocal -> Nothing + FLRelative link -> Just ("a " <> styleIfNeeded Faint "relative" <> " link", build link) + FLAbsolute link -> Just ("an " <> styleIfNeeded Faint "absolute" <> " link", build link) + RIExternal (ELUrl url) -> Just ("an " <> styleIfNeeded Faint "external" <> " link", build url) + RIExternal (ELOther url) -> Just ("a link", build url) + +pprLinkTyp :: Given ColorMode => ReferenceInfo -> Builder +pprLinkTyp rInfo = + paren $ styleIfNeeded Faint $ case rInfo of + RIFile ReferenceInfoFile{rifLink} -> + case rifLink of + FLLocal -> "file-local" + FLRelative _ -> "relative" + FLAbsolute _ -> "absolute" + RIExternal _ -> "external" + +pprLinkCtx :: Given ColorMode => ReferenceInfo -> Builder +pprLinkCtx rInfo = + case pprLink rInfo of + Nothing -> mempty + Just (b1, b2) -> "when processing " <> b1 <> ":\n" <> interpolateIndentF 2 b2 <> "\n" + +reportVerifyErrs + :: Given ColorMode => NonEmpty (WithReferenceLoc VerifyError) -> IO () +reportVerifyErrs errs = do + traverse_ (fmtLn . pprVerifyErr) errs + fmtLn $ colorIfNeeded Red $ + "Invalid references dumped, " <> build (length errs) <> " in total." + data RetryAfter = Date UTCTime | Seconds (Time Second) deriving stock (Show, Eq) @@ -211,11 +365,6 @@ fromString $ formatTime defaultTimeLocale rfc822DateFormat d build (Seconds s) = nameF "seconds" $ show s --- | Determine whether the verification result contains a fixable error. -isFixable :: VerifyError -> Bool -isFixable (ExternalHttpTooManyRequests _) = True -isFixable _ = False - data NeedsCaching key = NoCaching | CacheUnderKey key @@ -230,53 +379,98 @@ -- then the @action@ will not be executed, and the value is added to the accumulator list. -- After the whole list has been traversed, the accumulator is traversed once again to ensure -- every asynchronous action is completed. +-- If interrupted by AsyncException, returns this exception and list of already calcualted results +-- (their subset can be arbitrary). Computations that were not ended till this moment are cancelled. forConcurrentlyCaching - :: Ord cacheKey - => [a] -> (a -> NeedsCaching cacheKey) -> (a -> IO b) -> IO [b] + :: forall a b cacheKey. Ord cacheKey + => [a] -> (a -> NeedsCaching cacheKey) -> (a -> IO b) -> IO (Either (AsyncException, [b]) [b]) forConcurrentlyCaching list needsCaching action = go [] M.empty list where - go acc cached (x : xs) = case needsCaching x of - NoCaching -> do - withAsync (action x) $ \b -> - go (b : acc) cached xs - CacheUnderKey cacheKey -> do - case M.lookup cacheKey cached of - Nothing -> do + go + :: [Async b] + -> Map cacheKey (Async b) + -> [a] + -> IO (Either (AsyncException, [b]) [b]) + go acc cached items = + case items of + + (x : xs) -> case needsCaching x of + NoCaching -> do withAsync (action x) $ \b -> - go (b : acc) (M.insert cacheKey b cached) xs - Just b -> go (b : acc) cached xs - go acc _ [] = for acc wait <&> reverse + go (b : acc) cached xs + CacheUnderKey cacheKey -> do + case M.lookup cacheKey cached of + Nothing -> do + withAsync (action x) $ \b -> + go (b : acc) (M.insert cacheKey b cached) xs + Just b -> go (b : acc) cached xs + [] -> handleAsync + -- Wait for all children threads to complete. + -- + -- If, while the threads are running, the user hits Ctrl+C, + -- a `UserInterrupt :: AsyncException` will be thrown onto the main thread. + -- We catch it here, cancel all child threads, + -- and return the results of only the threads that finished successfully. + (\case + UserInterrupt -> do + partialResults <- for acc \asyncAction -> do + cancel asyncAction + poll asyncAction <&> \case + Just (Right a) -> Just a + Just (Left _ex) -> Nothing + Nothing -> Nothing + pure $ Left (UserInterrupt, catMaybes partialResults) + otherAsyncEx -> throwM otherAsyncEx + ) + $ Right . reverse <$> for acc wait + -- If action was already completed, then @cancel@ will have no effect, and we + -- will get result from @cancel f >> poll f@. Otherwise action will be interrupted, + -- so poll will return @Left (SomeException AsyncCancelled)@ + verifyRepo :: Given ColorMode => Rewrite - -> VerifyConfig + -> Config -> VerifyMode - -> FilePath -> RepoInfo -> IO (VerifyResult $ WithReferenceLoc VerifyError) verifyRepo rw - config@VerifyConfig{..} + config@Config{..} mode - root - repoInfo'@(RepoInfo files _) + repoInfo@RepoInfo{..} = do let toScan = do - (file, fileInfo) <- M.toList files - guard . not $ matchesGlobPatterns root vcNotScanned file + (canonicalFile, (file, fileInfo)) <- toPairs riFiles + guard . not $ matchesGlobPatterns (ecIgnoreRefsFrom cExclusions) canonicalFile case fileInfo of - Just fi -> do + Scanned fi -> do ref <- _fiReferences fi return (file, ref) - Nothing -> empty -- no support for such file, can do nothing + NotScannable -> empty -- No support for such file, can do nothing. + NotAddedToGit -> empty -- If this file is scannable, we've notified + -- user that we are scanning only files + -- added to Git while gathering RepoInfo. progressRef <- newIORef $ initVerifyProgress (map snd toScan) - + domainsReturned429Ref <- newIORef S.empty accumulated <- loopAsyncUntil (printer progressRef) do forConcurrentlyCaching toScan ifExternalThenCache $ \(file, ref) -> - verifyReference config mode progressRef repoInfo' root file ref - return $ fold accumulated + verifyReference config mode domainsReturned429Ref progressRef repoInfo file ref + case accumulated of + Right res -> return $ fold res + Left (exception, partialRes) -> do + -- The user has hit Ctrl+C; display any verification errors we managed to find and exit. + let errs = verifyErrors (fold partialRes) + total = length toScan + checked = length partialRes + whenJust errs reportVerifyErrs + fmt [int|A| + Interrupted (#s{exception}), checked #{checked} out of #{total} references. + |] + exitFailure + where printer :: IORef VerifyProgress -> IO () printer progressRef = do @@ -292,257 +486,220 @@ threadDelay (ms 100) ifExternalThenCache :: (a, Reference) -> NeedsCaching Text - ifExternalThenCache (_, Reference{..}) = case locationType rLink of - ExternalLoc -> CacheUnderKey rLink - _ -> NoCaching + ifExternalThenCache (_, Reference{..}) = + case rInfo of + RIExternal (ELUrl url) -> + CacheUnderKey url + _ -> + NoCaching -shouldCheckLocType :: VerifyMode -> LocationType -> Bool -shouldCheckLocType mode locType - | isExternal locType = shouldCheckExternal mode - | isLocal locType = shouldCheckLocal mode - | otherwise = False +shouldCheckLocType :: VerifyMode -> ReferenceInfo -> Bool +shouldCheckLocType mode rInfo = + case rInfo of + RIFile _ -> shouldCheckLocal mode + RIExternal (ELUrl _) -> shouldCheckExternal mode + RIExternal (ELOther _) -> False verifyReference - :: VerifyConfig + :: Config -> VerifyMode + -> IORef (S.Set DomainName) -> IORef VerifyProgress -> RepoInfo - -> FilePath - -> FilePath + -> RelPosixLink -> Reference -> IO (VerifyResult $ WithReferenceLoc VerifyError) verifyReference - config@VerifyConfig{..} + config@Config{..} mode + domainsReturned429Ref progressRef - (RepoInfo files dirs) - root - fileWithReference + repoInfo + file ref@Reference{..} - = retryVerification 0 $ do - let locType = locationType rLink - if shouldCheckLocType mode locType - then case locType of - CurrentFileLoc -> checkRef rAnchor fileWithReference - RelativeLoc -> checkRef rAnchor - (normalise $ takeDirectory fileWithReference - toString (canonizeLocalRef rLink)) - AbsoluteLoc -> checkRef rAnchor (root <> toString rLink) - ExternalLoc -> checkExternalResource config rLink - OtherLoc -> verifying pass - else return mempty + = fmap (fmap addReference . toVerifyRes) $ + retryVerification (RetryCounter 0 0) $ runExceptT $ + if shouldCheckLocType mode rInfo + then case rInfo of + RIFile ReferenceInfoFile{..} -> + case rifLink of + FLLocal -> + checkRef rifAnchor file + FLRelative link -> + checkRef rifAnchor $ takeDirectory file link + FLAbsolute link -> + checkRef rifAnchor link + RIExternal (ELUrl url) -> + checkExternalResource emptyChain config url + RIExternal (ELOther _) -> + pass + else pass where + addReference :: VerifyError -> WithReferenceLoc VerifyError + addReference = WithReferenceLoc file ref + retryVerification - :: Int - -> IO (VerifyResult VerifyError) - -> IO (VerifyResult $ WithReferenceLoc VerifyError) - retryVerification numberOfRetries resIO = do - res@(VerifyResult ves) <- resIO + :: RetryCounter + -> IO (Either VerifyError ()) + -> IO (Either VerifyError ()) + retryVerification rc resIO = do + res <- resIO + case res of + -- Success + Right () -> modifyProgressRef Nothing reportSuccess $> res + Left err -> do + setOfReturned429 <- addDomainIf429 domainsReturned429Ref err + case decideWhetherToRetry setOfReturned429 rc err of + -- Unfixable + Nothing -> modifyProgressRef Nothing reportError $> res + -- Fixable, retry + Just (mbCurrentRetryAfter, counterModifier) -> do + now <- getPOSIXTime <&> posixTimeToTimeSecond - now <- getPOSIXTime <&> posixTimeToTimeSecond + let toSeconds = \case + Seconds s -> s + -- Calculates the seconds left until @Retry-After@ date. + -- Defaults to 0 if the date has already passed. + Date date | utcTimeToTimeSecond date >= now -> utcTimeToTimeSecond date -:- now + _ -> sec 0 - let toSeconds = \case - Seconds s -> s - -- Calculates the seconds left until @Retry-After@ date. - -- Defaults to 0 if the date has already passed. - Date date | utcTimeToTimeSecond date >= now -> utcTimeToTimeSecond date -:- now - _ -> sec 0 + let currentRetryAfter = fromMaybe (ncDefaultRetryAfter cNetworking) $ + fmap toSeconds mbCurrentRetryAfter - let toRetry = any isFixable ves && numberOfRetries < vcMaxRetries - currentRetryAfter = fromMaybe vcDefaultRetryAfter $ - extractRetryAfterInfo res <&> toSeconds + modifyProgressRef (Just (now, currentRetryAfter)) reportRetry + threadDelay currentRetryAfter + retryVerification (counterModifier rc) resIO - let moveProgress = alterOverallProgress numberOfRetries - . alterProgressErrors res numberOfRetries + modifyProgressRef + :: Maybe (Time Second, Time Second) + -> (forall w. Ord w => w -> Progress Int w -> Progress Int w) + -> IO () + modifyProgressRef mbRetryData moveProgress = atomicModifyIORef' progressRef $ \VerifyProgress{..} -> + ( case rInfo of + RIFile _ -> VerifyProgress{ vrLocal = moveProgress () vrLocal, .. } + RIExternal (ELOther _) -> VerifyProgress{ vrLocal = moveProgress () vrLocal, .. } + RIExternal (ELUrl url) -> VerifyProgress{ vrExternal = + let vrExternalAdvanced = moveProgress url vrExternal + in case mbRetryData of + Just (now, retryAfter) -> case getTaskTimestamp vrExternal of + Just (TaskTimestamp ttc start) + | retryAfter +:+ now <= ttc +:+ start -> vrExternalAdvanced + _ -> setTaskTimestamp url retryAfter now vrExternalAdvanced + Nothing -> vrExternalAdvanced, .. } + , () + ) - atomicModifyIORef' progressRef $ \VerifyProgress{..} -> - ( if isExternal $ locationType rLink - then VerifyProgress{ vrExternal = - let vrExternalAdvanced = moveProgress vrExternal - in if toRetry - then case pTaskTimestamp vrExternal of - Just (TaskTimestamp ttc start) - | currentRetryAfter +:+ now <= ttc +:+ start -> vrExternalAdvanced - _ -> setTaskTimestamp currentRetryAfter now vrExternalAdvanced - else vrExternalAdvanced, .. } - else VerifyProgress{ vrLocal = moveProgress vrLocal, .. } - , () - ) - if toRetry - then do - threadDelay currentRetryAfter - retryVerification (numberOfRetries + 1) resIO - else return $ fmap (WithReferenceLoc fileWithReference ref) res + addDomainIf429 :: IORef (S.Set DomainName) -> VerifyError -> IO (S.Set DomainName) + addDomainIf429 setRef err = atomicModifyIORef' setRef $ \s -> + (\x -> (x, x)) $ case err of + ExternalHttpTooManyRequests _ mbDomain -> + maybe s (flip S.insert s) mbDomain + _ -> s - alterOverallProgress - :: (Num a) - => Int - -> Progress a - -> Progress a - alterOverallProgress retryNumber - | retryNumber > 0 = id - | otherwise = incProgress + decideWhetherToRetry + :: S.Set DomainName + -> RetryCounter + -> VerifyError + -> Maybe (Maybe RetryAfter, RetryCounter -> RetryCounter) + decideWhetherToRetry setOfReturned429 rc = \case + ExternalHttpTooManyRequests retryAfter _ + | totalRetriesNotExceeded -> Just (retryAfter, incTotalCounter) + ExternalHttpTimeout (Just domain) + | totalRetriesNotExceeded && timeoutRetriesNotExceeded -> + -- If a given domain ever returned 429 error, we assume that getting timeout from + -- the domain can be considered as a 429-like error, and hence we retry. + -- If there was no 429 responses from this domain, then getting timeout from + -- it probably means that this site is not working at all. + -- Also, there always remains a possibility that we just didn't get the response + -- in time, but we can't avoid this case here, the only thing that can help + -- is to increase the allowed timeout in the config. - alterProgressErrors - :: (Num a) - => VerifyResult VerifyError - -> Int - -> Progress a - -> Progress a - alterProgressErrors res@(VerifyResult ves) retryNumber - | vcMaxRetries == 0 = - if ok then id - else incProgressUnfixableErrors - | retryNumber == 0 = - if ok then id - else if fixable then incProgressFixableErrors - else incProgressUnfixableErrors - | retryNumber == vcMaxRetries = - if ok then decProgressFixableErrors - else fixableToUnfixable - -- 0 < retryNumber < vcMaxRetries - | otherwise = - if ok then decProgressFixableErrors - else if fixable then id - else fixableToUnfixable + if S.member domain setOfReturned429 + then Just (Just (Seconds $ sec 0), incTimeoutCounter . incTotalCounter) + else Nothing + _ -> Nothing where - ok = verifyOk res - fixable = any isFixable ves + totalRetriesNotExceeded = rcTotalRetries rc < ncMaxRetries cNetworking + timeoutRetriesNotExceeded = rcTimeoutRetries rc < ncMaxTimeoutRetries cNetworking - extractRetryAfterInfo :: VerifyResult VerifyError -> Maybe RetryAfter - extractRetryAfterInfo = \case - VerifyResult [ExternalHttpTooManyRequests retryAfter] -> retryAfter - _ -> Nothing + isVirtual = matchesGlobPatterns (ecIgnoreLocalRefsTo cExclusions) - isVirtual = matchesGlobPatterns root vcVirtualFiles + -- Checks a local file reference. + checkRef :: Maybe Text -> RelPosixLink -> ExceptT VerifyError IO () + checkRef mAnchor referredFile = do + let canonicalFile = canonicalizeRelPosixLink referredFile + unless (isVirtual canonicalFile) do + when (hasUnexpanededParentIndirections canonicalFile) $ + throwError $ LocalFileOutsideRepo referredFile - checkRef mAnchor referredFile = verifying $ - unless (isVirtual referredFile) do - checkReferredFileIsInsideRepo referredFile - checkReferredFileExists referredFile - case lookupFilePath referredFile $ M.toList files of - Nothing -> pass -- no support for such file, can do nothing - Just referredFileInfo -> whenJust mAnchor $ + mFileStatus <- tryGetFileStatus referredFile + case mFileStatus of + Right (Scanned referredFileInfo) -> whenJust mAnchor $ checkAnchor referredFile (_fiAnchors referredFileInfo) - - lookupFilePath :: FilePath -> [(FilePath, Maybe FileInfo)] -> Maybe FileInfo - lookupFilePath fp = snd <=< find (equalFilePath (expandIndirections fp) . fst) - - -- expands ".." and "." - -- expandIndirections "a/b/../c" = "a/c" - -- expandIndirections "a/b/c/../../d" = "a/d" - -- expandIndirections "../../a" = "../../a" - -- expandIndirections "a/./b" = "a/b" - -- expandIndirections "a/b/./../c" = "a/c" - expandIndirections :: FilePath -> FilePath - expandIndirections = joinPath . reverse . expand 0 . reverse . splitDirectories - where - expand :: Int -> [FilePath] -> [FilePath] - expand acc ("..":xs) = expand (acc+1) xs - expand acc (".":xs) = expand acc xs - expand 0 (x:xs) = x : expand 0 xs - expand acc (_:xs) = expand (acc-1) xs - expand acc [] = replicate acc ".." - - checkReferredFileIsInsideRepo file = unless - (noNegativeNesting $ makeRelative root file) $ - throwError (LocalFileOutsideRepo file) - where - -- checks that relative filepath fully belongs to the root directory - -- noNegativeNesting "a/../b" = True - -- noNegativeNesting "a/../../b" = False - noNegativeNesting path = all (>= 0) $ scanl - (\n dir -> n + nestingChange dir) - (0 :: Integer) - $ splitDirectories path + Right NotAddedToGit -> throwError (LinkTargetNotAddedToGit referredFile) + Left UntrackedDirectory -> throwError (LinkTargetNotAddedToGit referredFile) + Right NotScannable -> pass -- no support for such file, can do nothing + Left TrackedDirectory -> pass -- path leads to directory, currently + -- if such link contain anchor, we ignore it - nestingChange ".." = -1 - nestingChange "." = 0 - nestingChange _ = 1 + caseInsensitive = caseInsensitiveAnchors . mcFlavor . scMarkdown $ cScanners - checkReferredFileExists file = do - unless (fileExists || dirExists) $ - throwError (LocalFileDoesNotExist file) + -- Returns `Nothing` when path corresponds to an existing (and tracked) directory + tryGetFileStatus :: RelPosixLink -> ExceptT VerifyError IO (Either DirectoryStatus FileStatus) + tryGetFileStatus filePath + | Just f <- lookupFile canonicalFile repoInfo = return (Right f) + | Just d <- lookupDirectory canonicalFile repoInfo = return (Left d) + | otherwise = throwError (LocalFileDoesNotExist filePath) where - matchesFilePath :: FilePath -> Bool - matchesFilePath = equalFilePath $ expandIndirections file - - fileExists :: Bool - fileExists = any matchesFilePath $ M.keys files - - dirExists :: Bool - dirExists = any matchesFilePath dirs + canonicalFile = canonicalizeRelPosixLink filePath - checkAnchor file fileAnchors anchor = do - checkAnchorReferenceAmbiguity file fileAnchors anchor - checkDeduplicatedAnchorReference file fileAnchors anchor + checkAnchor filePath fileAnchors anchor = do + checkAnchorReferenceAmbiguity filePath fileAnchors anchor + checkDeduplicatedAnchorReference filePath fileAnchors anchor checkAnchorExists fileAnchors anchor + anchorNameEq = + if caseInsensitive + then (==) `on` toCaseFold + else (==) + -- Detect a case when original file contains two identical anchors, github -- has added a suffix to the duplicate, and now the original is referrenced - -- such links are pretty fragile and we discourage their use despite -- they are in fact unambiguous. - checkAnchorReferenceAmbiguity file fileAnchors anchor = do - let similarAnchors = filter ((== anchor) . aName) fileAnchors + checkAnchorReferenceAmbiguity filePath fileAnchors anchor = do + let similarAnchors = filter (anchorNameEq anchor . aName) fileAnchors when (length similarAnchors > 1) $ - throwError $ AmbiguousAnchorRef file anchor (Exts.fromList similarAnchors) + throwError $ AmbiguousAnchorRef filePath anchor (Exts.fromList similarAnchors) -- Similar to the previous one, but for the case when we reference the -- renamed duplicate. - checkDeduplicatedAnchorReference file fileAnchors anchor = + checkDeduplicatedAnchorReference filePath fileAnchors anchor = whenJust (stripAnchorDupNo anchor) $ \origAnchor -> - checkAnchorReferenceAmbiguity file fileAnchors origAnchor + checkAnchorReferenceAmbiguity filePath fileAnchors origAnchor checkAnchorExists givenAnchors anchor = - case find ((== anchor) . aName) givenAnchors of + case find (anchorNameEq anchor . aName) givenAnchors of Just _ -> pass Nothing -> - let isSimilar = (>= vcAnchorSimilarityThreshold) - similarAnchors = - filter (isSimilar . realToFrac . damerauLevenshteinNorm anchor . aName) - givenAnchors + let isSimilar = (>= scAnchorSimilarityThreshold cScanners) + distance = damerauLevenshteinNorm `on` toCaseFold + similarAnchors = flip filter givenAnchors + $ isSimilar + . realToFrac + . distance anchor + . aName in throwError $ AnchorDoesNotExist anchor similarAnchors --- | Parse URI according to RFC 3986 extended by allowing non-encoded --- `[` and `]` in query string. -parseUri :: Text -> ExceptT VerifyError IO URI -parseUri link = do - -- There exist two main standards of URL parsing: RFC 3986 and the Web - -- Hypertext Application Technology Working Group's URL standard. Ideally, - -- we want to be able to parse the URLs in accordance with the latter - -- standard, because it provides a much less ambiguous set of rules for - -- percent-encoding special characters, and is essentially a living - -- standard that gets updated constantly. - -- - -- We have chosen the 'uri-bytestring' library for URI parsing because - -- of the 'laxURIParseOptions' parsing configuration. 'mkURI' from - -- the 'modern-uri' library parses URIs in accordance with RFC 3986 and does - -- not provide a means of parsing customization, which contrasts with - -- 'parseURI' that accepts a 'URIParserOptions'. One of the predefined - -- configurations of this type is 'strictURIParserOptions', which follows - -- RFC 3986, and the other -- 'laxURIParseOptions' -- allows brackets - -- in the queries, which draws us closer to the WHATWG URL standard. - uri' <- URIBS.parseURI URIBS.laxURIParserOptions (encodeUtf8 link) - & either (throwError . ExternalResourceInvalidUri) pure - - -- We stick to our infrastructure by continuing to operate on the datatypes - -- from `modern-uri`, which are used in the 'req' library. First we - -- serialize our URI parsed with 'parseURI' so it becomes a 'ByteString' - -- with all the necessary special characters *percent-encoded*, and then - -- call 'mkURIBs'. - mkURIBs (URIBS.serializeURIRef' uri') - -- Ideally, this exception should never be thrown, as the URI - -- already *percent-encoded* with 'parseURI' from 'uri-bytestring' - -- and 'mkURIBs' is only used to convert to 'URI' type from - -- 'modern-uri' package. - & handleJust (fromException @ParseExceptionBs) - (throwError . ExternalResourceUriConversionError) - -checkExternalResource :: VerifyConfig -> Text -> IO (VerifyResult VerifyError) -checkExternalResource VerifyConfig{..} link - | isIgnored = return mempty - | otherwise = fmap toVerifyRes $ runExceptT $ do - uri <- parseUri link +checkExternalResource :: RedirectChain -> Config -> Text -> ExceptT VerifyError IO () +checkExternalResource followed config@Config{..} link + | isIgnored = pass + | followed `hasRequest` (RedirectChainLink link) = + throwError $ RedirectChainCycle $ followed `pushRequest` (RedirectChainLink link) + | ncMaxRedirectFollows >= 0 && totalFollowed followed > ncMaxRedirectFollows = + throwError $ RedirectChainLimit $ followed `pushRequest` (RedirectChainLink link) + | otherwise = do + uri <- ExternalResourceUriParseError `withExceptT` parseUri False link case toString <$> uriScheme uri of Just "http" -> checkHttp uri Just "https" -> checkHttp uri @@ -550,22 +707,19 @@ Just "ftps" -> checkFtp uri True _ -> throwError ExternalResourceUnknownProtocol where - isIgnored = doesMatchAnyRegex link vcIgnoreRefs + ExclusionConfig{..} = cExclusions + NetworkingConfig{..} = cNetworking - doesMatchAnyRegex :: Text -> ([Regex] -> Bool) - doesMatchAnyRegex src = any $ \regex -> - case regexec regex src of - Right res -> case res of - Just (before, match, after, _) -> - null before && null after && not (null match) - Nothing -> False - Left _ -> False + isIgnored = doesMatchAnyRegex link ecIgnoreExternalRefsTo checkHttp :: URI -> ExceptT VerifyError IO () checkHttp uri = makeHttpRequest uri HEAD 0.3 `catchError` \case - e | isFixable e -> throwError e + e@(ExternalHttpTooManyRequests _ _) -> throwError e _ -> makeHttpRequest uri GET 0.7 + httpConfig :: HttpConfig + httpConfig = defaultHttpConfig { httpConfigRedirectCount = 0 } + makeHttpRequest :: (HttpMethod method, HttpBodyAllowed (AllowsBody method) 'NoBody) => URI @@ -579,43 +733,91 @@ -- so just in case we throw exception here Nothing -> throwError $ ExternalResourceInvalidUrl Nothing Just u -> pure u + let reqLink = case parsedUrl of Left (url, option) -> - runReq defaultHttpConfig $ - req method url NoReqBody ignoreResponse option + runReq httpConfig $ + req method url NoReqBody ignoreResponse option Right (url, option) -> - runReq defaultHttpConfig $ - req method url NoReqBody ignoreResponse option + runReq httpConfig $ + req method url NoReqBody ignoreResponse option - let maxTime = Time @Second $ unTime vcExternalRefCheckTimeout * timeoutFrac + let maxTime = Time @Second $ unTime ncExternalRefCheckTimeout * timeoutFrac - mres <- liftIO (timeout maxTime $ void reqLink) `catch` - (either throwError (\() -> return (Just ())) . interpretErrors) - maybe (throwError $ ExternalResourceSomeError "Response timeout") pure mres + reqRes <- catch (liftIO (timeout maxTime $ reqLink $> RRDone)) $ + (Just <$>) <$> interpretHttpErrors uri + case reqRes of + Nothing -> throwError $ ExternalHttpTimeout $ extractHost uri + Just RRDone -> pass + Just (RRFollow nextLink) -> + checkExternalResource (followed `pushRequest` (RedirectChainLink link)) config nextLink + + extractHost :: URI -> Maybe DomainName + extractHost = + either (const Nothing) (Just . DomainName . unRText . authHost) . uriAuthority + + isAllowedErrorCode :: Int -> Bool isAllowedErrorCode = or . sequence -- We have to stay conservative - if some URL can be accessed under -- some circumstances, we should do our best to report it as fine. - [ if vcIgnoreAuthFailures -- unauthorized access + [ if ncIgnoreAuthFailures -- unauthorized access then flip elem [403, 401] else const False - , (405 ==) -- method mismatch + , (405 ==) -- method mismatch ] - interpretErrors = \case + interpretHttpErrors :: URI -> Network.HTTP.Req.HttpException -> ExceptT VerifyError IO ResponseResult + interpretHttpErrors uri = \case JsonHttpException _ -> error "External link JSON parse exception" - VanillaHttpException err -> case err of + VanillaHttpException err -> interpretHttpErrors' uri err + + interpretHttpErrors' :: URI -> Network.HTTP.Client.HttpException -> ExceptT VerifyError IO ResponseResult + interpretHttpErrors' uri = \case InvalidUrlException{} -> error "External link URL invalid exception" HttpExceptionRequest _ exc -> case exc of StatusCodeException resp _ - | isAllowedErrorCode (statusCode $ responseStatus resp) -> Right () + | isRedirectCode code -> case redirectLocation of + Nothing -> throwError $ RedirectMissingLocation $ followed `pushRequest` RedirectChainLink link + Just nextLink -> do + nextUri <- ExternalResourceUriParseError `withExceptT` parseUri True nextLink + nextLinkAbsolute <- case relativeTo nextUri uri of + -- This should not happen because uri has been parsed with `parseUri False` + Nothing -> error "Not an absolute URL exception" + Just absoluteTarget -> pure $ render absoluteTarget + case redirectRule link nextLinkAbsolute code ncExternalRefRedirects of + Nothing -> pure RRDone + Just RedirectRule{..} -> + case rrOutcome of + RROValid -> pure RRDone + RROInvalid -> throwError $ RedirectRuleError + (followed `pushRequest` RedirectChainLink link `pushRequest` RedirectChainLink nextLinkAbsolute) + rrOn + RROFollow -> pure $ RRFollow nextLinkAbsolute + | isAllowedErrorCode code -> pure RRDone | otherwise -> case statusCode (responseStatus resp) of - 429 -> Left . ExternalHttpTooManyRequests $ retryAfterInfo resp - _ -> Left . ExternalHttpResourceUnavailable $ responseStatus resp - other -> Left . ExternalResourceSomeError $ show other + 429 -> throwError $ ExternalHttpTooManyRequests (retryAfterInfo resp) (extractHost uri) + _ -> throwError $ ExternalHttpResourceUnavailable $ responseStatus resp + where + code :: Int + code = statusCode $ responseStatus resp + + redirectLocation :: Maybe Text + redirectLocation = fmap decodeUtf8 + . lookup "Location" + $ responseHeaders resp + + ConnectionFailure _ -> throwError ExternalResourceConnectionFailure + InternalException e + | Just (N.C.HostCannotConnect _ _) <- fromException e + -> throwError ExternalResourceConnectionFailure + + other -> throwError $ ExternalResourceSomeError $ show other where retryAfterInfo :: Response a -> Maybe RetryAfter - retryAfterInfo = readMaybe . decodeUtf8 <=< L.lookup hRetryAfter . responseHeaders + retryAfterInfo = + readMaybe @_ @Text . decodeUtf8 <=< + L.lookup hRetryAfter . responseHeaders checkFtp :: URI -> Bool -> ExceptT VerifyError IO () checkFtp uri secure = do @@ -648,26 +850,26 @@ -> Bool -> ExceptT VerifyError IO () makeFtpRequest host port path secure = handler host port $ - \handle response -> do + \ftpHandle response -> do -- check connection status when (frStatus response /= Success) $ throwError $ ExternalFtpResourceUnavailable response -- anonymous login - loginResp <- login handle "anonymous" "" + loginResp <- login ftpHandle "anonymous" "" -- check login status when (frStatus loginResp /= Success) $ - if vcIgnoreAuthFailures + if ncIgnoreAuthFailures then pure () else throwError $ ExternalFtpException $ UnsuccessfulException loginResp -- If the response is non-null, the path is definitely a directory; -- If the response is null, the path may be a file or may not exist. - dirList <- nlst handle [ "-a", path ] + dirList <- nlst ftpHandle [ "-a", path ] when (BS.null dirList) $ do -- The server-PI will respond to the SIZE command with a 213 reply -- giving the transfer size of the file whose pathname was supplied, -- or an error response if the file does not exist, the size is -- unavailable, or some other error has occurred. - _ <- size handle path `catch` \case + _ <- size ftpHandle path `catch` \case UnsuccessfulException _ -> throwError $ FtpEntryDoesNotExist path FailureException FTPResponse{..} | frCode == 550 -> throwError $ FtpEntryDoesNotExist path diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -9,7 +9,12 @@ import Universum import Test.Tasty +import Test.Tasty.Ingredients (Ingredient) +import Test.Xrefcheck.Util (mockServerOptions) import Tree (tests) main :: IO () -main = tests >>= defaultMain +main = tests >>= defaultMainWithIngredients ingredients + +ingredients :: [Ingredient] +ingredients = includingOptions mockServerOptions : defaultIngredients diff --git a/tests/Test/Xrefcheck/AnchorsInHeadersSpec.hs b/tests/Test/Xrefcheck/AnchorsInHeadersSpec.hs --- a/tests/Test/Xrefcheck/AnchorsInHeadersSpec.hs +++ b/tests/Test/Xrefcheck/AnchorsInHeadersSpec.hs @@ -5,22 +5,24 @@ module Test.Xrefcheck.AnchorsInHeadersSpec where -import Universum +import Universum hiding ((^.)) +import Control.Lens ((^.)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) import Test.Xrefcheck.Util import Xrefcheck.Core +import Xrefcheck.System test_anchorsInHeaders :: TestTree test_anchorsInHeaders = testGroup "Anchors in headers" [ testCase "Check if anchors in headers are recognized" $ do - (fi, errs) <- parse GitHub "tests/markdowns/without-annotations/anchors_in_headers.md" + (fi, errs) <- parse GitHub "" $ mkRelPosixLink "tests/markdowns/without-annotations/anchors_in_headers.md" getAnchors fi @?= ["some-stuff", "stuff-section"] errs @?= [] , testCase "Check if anchors with id attributes are recognized" $ do - (fi, errs) <- parse GitHub "tests/markdowns/without-annotations/anchors_in_headers_with_id_attribute.md" + (fi, errs) <- parse GitHub "" $ mkRelPosixLink "tests/markdowns/without-annotations/anchors_in_headers_with_id_attribute.md" getAnchors fi @?= ["some-stuff-with-id-attribute", "stuff-section-with-id-attribute"] errs @?= [] ] diff --git a/tests/Test/Xrefcheck/AnchorsSpec.hs b/tests/Test/Xrefcheck/AnchorsSpec.hs --- a/tests/Test/Xrefcheck/AnchorsSpec.hs +++ b/tests/Test/Xrefcheck/AnchorsSpec.hs @@ -3,15 +3,17 @@ - SPDX-License-Identifier: MPL-2.0 -} -module Test.Xrefcheck.AnchorsSpec (test_anchors) where +module Test.Xrefcheck.AnchorsSpec where -import Universum +import Universum hiding ((^.)) +import Control.Lens ((^.)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) import Test.Xrefcheck.Util import Xrefcheck.Core +import Xrefcheck.System checkHeaderConversions :: Flavor -> [(Text, Text)] -> TestTree checkHeaderConversions fl suites = @@ -19,7 +21,7 @@ [testCase (show a <> " == " <> show b) $ headerToAnchor fl a @?= b | (a,b) <- suites] ++ [ testCase "Non-stripped header name should be stripped" $ do - (fi, errs) <- parse fl "tests/markdowns/without-annotations/non_stripped_spaces.md" + (fi, errs) <- parse fl "" $ mkRelPosixLink "tests/markdowns/without-annotations/non_stripped_spaces.md" getAnchors fi @?= [ case fl of GitHub -> "header--with-leading-spaces" GitLab -> "header-with-leading-spaces" , "edge-case" diff --git a/tests/Test/Xrefcheck/CanonicalRelPosixLinkSpec.hs b/tests/Test/Xrefcheck/CanonicalRelPosixLinkSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Xrefcheck/CanonicalRelPosixLinkSpec.hs @@ -0,0 +1,49 @@ +{- SPDX-FileCopyrightText: 2023 Serokell + - + - SPDX-License-Identifier: MPL-2.0 + -} + +module Test.Xrefcheck.CanonicalRelPosixLinkSpec where + +import Universum + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?), (@?=)) + +import Xrefcheck.System + +test_canonicalRelPosixLink :: TestTree +test_canonicalRelPosixLink = + testGroup "Canonical relative POSIX links" + [ testGroup "Normalization" + [ testCase "Trailing separator" $ + on (@?=) mkCanonicalLink "./example/dir/" "example/dir" + , testCase "Parent directory indirection" $ + on (@?=) mkCanonicalLink "dir1/../dir2" "dir2" + , testCase "Through parent directory indirection" $ + hasUnexpanededParentIndirections (mkCanonicalLink "dir1/../../../dir2") @? "Unexpanded indirections" + , testCase "Current directory indirection" $ + on (@?=) mkCanonicalLink "././dir1/./././dir2/././" "dir1/dir2" + , testCase "Mixed indirections result in current directory" $ + on (@?=) mkCanonicalLink "././dir1/./.././dir2/./../" "." + ] + , testGroup "Intermediate directories" + [ testCase "Current directory itself" $ + on (@?=) (fmap canonicalizeRelPosixLink) (getIntermediateDirs (mkRelPosixLink ".")) $ + fmap mkRelPosixLink ["."] + , testCase "Current directory file" $ + on (@?=) (fmap canonicalizeRelPosixLink) (getIntermediateDirs (mkRelPosixLink "./file")) $ + fmap mkRelPosixLink ["."] + , testCase "Parent directory itself" $ + on (@?=) (fmap canonicalizeRelPosixLink) (getIntermediateDirs (mkRelPosixLink "..")) $ + fmap mkRelPosixLink ["."] + , testCase "Parent directory file" $ + on (@?=) (fmap canonicalizeRelPosixLink) (getIntermediateDirs (mkRelPosixLink "../file")) $ + fmap mkRelPosixLink [".", ".."] + , testCase "Intermediate directories" $ + on (@?=) (fmap canonicalizeRelPosixLink) (getIntermediateDirs (mkRelPosixLink "./example/dir/file")) $ + fmap mkRelPosixLink [".", "example", "example/dir"] + ] + ] + where + mkCanonicalLink = canonicalizeRelPosixLink . mkRelPosixLink diff --git a/tests/Test/Xrefcheck/ConfigSpec.hs b/tests/Test/Xrefcheck/ConfigSpec.hs --- a/tests/Test/Xrefcheck/ConfigSpec.hs +++ b/tests/Test/Xrefcheck/ConfigSpec.hs @@ -5,25 +5,25 @@ module Test.Xrefcheck.ConfigSpec where -import Universum +import Universum hiding ((.~)) import Control.Concurrent (forkIO, killThread) import Control.Exception qualified as E +import Control.Lens ((.~)) -import Data.ByteString qualified as BS import Data.List (isInfixOf) import Data.Yaml (ParseException (..), decodeEither') import Network.HTTP.Types (Status (..)) -import Test.Tasty (TestTree, testGroup) +import Test.Tasty (TestTree, askOption, testGroup) import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) import Test.Tasty.QuickCheck (ioProperty, testProperty) - -import Xrefcheck.Config (Config, Config' (..), VerifyConfig' (..), defConfig, defConfigText) +import Xrefcheck.Config import Xrefcheck.Core (Flavor (GitHub), allFlavors) -import Xrefcheck.Verify (VerifyError (..), VerifyResult (..), checkExternalResource) +import Xrefcheck.Scan (ecIgnoreExternalRefsToL) +import Xrefcheck.Verify (VerifyError (..), checkExternalResource) -import Test.Xrefcheck.Util (mockServer) +import Test.Xrefcheck.Util (mockServer, mockServerUrl) test_config :: [TestTree] test_config = @@ -31,47 +31,48 @@ testProperty (show flavor) $ ioProperty $ evaluateWHNF_ @_ @Config (defConfig flavor) | flavor <- allFlavors] - , testGroup "Filled default config matches the expected format" -- The config we match against can be regenerated with - -- stack exec xrefcheck -- dump-config -t GitHub -o tests/configs/github-config.yaml + -- stack exec xrefcheck -- dump-config -t GitHub -o tests/configs/github-config.yaml --force [ testCase "Config matches" $ do - config <- BS.readFile "tests/configs/github-config.yaml" + config <- readFile "tests/configs/github-config.yaml" when (config /= defConfigText GitHub) $ assertFailure $ toString $ unwords [ "Config does not match the expected format." , "Run" - , "`stack exec xrefcheck -- dump-config -t GitHub -o tests/configs/github-config.yaml`" + , "`stack exec xrefcheck -- dump-config -t GitHub -o tests/configs/github-config.yaml --force`" , "and verify changes" ] ] - , testGroup "`ignoreAuthFailures` working as expected" $ - let config = (cVerification $ defConfig GitHub) { vcIgnoreRefs = [] } + , askOption $ \mockServerPort -> + testGroup "`ignoreAuthFailures` working as expected" $ + let config = defConfig GitHub & cExclusionsL . ecIgnoreExternalRefsToL .~ [] + + setIgnoreAuthFailures value = + config & cNetworkingL . ncIgnoreAuthFailuresL .~ value in [ testCase "when True - assume 401 status is valid" $ - checkLinkWithServer (config { vcIgnoreAuthFailures = True }) - "http://127.0.0.1:3000/401" $ VerifyResult [] + checkLinkWithServer mockServerPort (setIgnoreAuthFailures True) + "/401" $ Right () , testCase "when False - assume 401 status is invalid" $ - checkLinkWithServer (config { vcIgnoreAuthFailures = False }) - "http://127.0.0.1:3000/401" $ VerifyResult - [ ExternalHttpResourceUnavailable $ + checkLinkWithServer mockServerPort (setIgnoreAuthFailures False) + "/401" $ + Left $ ExternalHttpResourceUnavailable $ Status { statusCode = 401, statusMessage = "Unauthorized" } - ] , testCase "when True - assume 403 status is valid" $ - checkLinkWithServer (config { vcIgnoreAuthFailures = True }) - "http://127.0.0.1:3000/403" $ VerifyResult [] + checkLinkWithServer mockServerPort (setIgnoreAuthFailures True) + "/403" $ Right () , testCase "when False - assume 403 status is invalid" $ - checkLinkWithServer (config { vcIgnoreAuthFailures = False }) - "http://127.0.0.1:3000/403" $ VerifyResult - [ ExternalHttpResourceUnavailable $ + checkLinkWithServer mockServerPort (setIgnoreAuthFailures False) + "/403" $ + Left $ ExternalHttpResourceUnavailable $ Status { statusCode = 403, statusMessage = "Forbidden" } - ] ] , testGroup "Config parser reject input with unknown fields" [ testCase "throws error with useful messages" $ do - case decodeEither' @Config (defConfigText GitHub <> "strangeField: []") of + case decodeEither' @Config $ encodeUtf8 $ defConfigText GitHub <> "strangeField: []" of Left (AesonException str) -> if "unknown fields: [\"strangeField\"]" `isInfixOf` str then pure () @@ -80,11 +81,9 @@ ] ] - - - where - checkLinkWithServer config link expectation = - E.bracket (forkIO mockServer) killThread $ \_ -> do - result <- checkExternalResource config link + checkLinkWithServer mockServerPort config link expectation = + E.bracket (forkIO (mockServer mockServerPort)) killThread $ \_ -> do + let url = mockServerUrl mockServerPort link + result <- runExceptT $ checkExternalResource emptyChain config url result @?= expectation diff --git a/tests/Test/Xrefcheck/IgnoreAnnotationsSpec.hs b/tests/Test/Xrefcheck/IgnoreAnnotationsSpec.hs --- a/tests/Test/Xrefcheck/IgnoreAnnotationsSpec.hs +++ b/tests/Test/Xrefcheck/IgnoreAnnotationsSpec.hs @@ -5,9 +5,11 @@ module Test.Xrefcheck.IgnoreAnnotationsSpec where -import Universum +import Universum hiding ((^.)) import CMarkGFM (PosInfo (..)) +import Control.Lens ((^.)) +import System.FilePath qualified as FP import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) @@ -15,51 +17,54 @@ import Xrefcheck.Core import Xrefcheck.Scan import Xrefcheck.Scanners.Markdown +import Xrefcheck.System test_ignoreAnnotations :: [TestTree] test_ignoreAnnotations = [ testGroup "Parsing failures" [ testCase "Check if broken link annotation produce error" do - let file = "tests/markdowns/with-annotations/no_link.md" + let file = "tests" FP. "markdowns" FP. "with-annotations" FP. "no_link.md" errs <- getErrs file - errs @?= makeError (Just $ PosInfo 7 1 7 31) file LinkErr + errs @?= makeError file (Just $ PosInfo 7 1 7 31) LinkErr , testCase "Check if broken paragraph annotation produce error" do - let file = "tests/markdowns/with-annotations/no_paragraph.md" + let file = "tests" FP. "markdowns" FP. "with-annotations" FP. "no_paragraph.md" errs <- getErrs file - errs @?= makeError (Just $ PosInfo 7 1 7 35) file (ParagraphErr "HEADING") - , testCase "Check if broken ignore file annotation produce error" do - let file = "tests/markdowns/with-annotations/unexpected_ignore_file.md" + errs @?= makeError file (Just $ PosInfo 7 1 7 35) (ParagraphErr "HEADING") + , testCase "Check if broken ignore all annotation produce error" do + let file = "tests" FP. "markdowns" FP. "with-annotations" FP. "unexpected_ignore_file.md" errs <- getErrs file - errs @?= makeError (Just $ PosInfo 9 1 9 30) file FileErr + errs @?= makeError file (Just $ PosInfo 9 1 9 29) FileErr , testCase "Check if broken unrecognised annotation produce error" do - let file = "tests/markdowns/with-annotations/unrecognised_option.md" + let file = "tests" FP. "markdowns" FP. "with-annotations" FP. "unrecognised_option.md" errs <- getErrs file - errs @?= makeError (Just $ PosInfo 7 1 7 46) file (UnrecognisedErr "unrecognised-option") + errs @?= makeError file (Just $ PosInfo 7 1 7 46) (UnrecognisedErr "unrecognised-option") ] , testGroup "\"ignore link\" mode" [ testCase "Check \"ignore link\" performance" $ do - let file = "tests/markdowns/with-annotations/ignore_link.md" - (fi, errs) <- parse GitHub file + let file = "tests" FP. "markdowns" FP. "with-annotations" FP. "ignore_link.md" + (fi, errs) <- parse GitHub "" (mkRelPosixLink file) getRefs fi @?= ["team", "team", "team", "hire-us", "how-we-work", "privacy", "link2", "link2", "link3"] - errs @?= makeError (Just $ PosInfo 42 1 42 31) file LinkErr + errs @?= makeError file (Just $ PosInfo 42 1 42 31) LinkErr ] , testGroup "\"ignore paragraph\" mode" [ testCase "Check \"ignore paragraph\" performance" $ do - (fi, errs) <- parse GitHub "tests/markdowns/with-annotations/ignore_paragraph.md" - getRefs fi @?= ["blog", "contacts"] - errs @?= [] + let file = mkRelPosixLink $ "tests" FP. "markdowns" FP. "with-annotations" FP. "ignore_paragraph.md" + (fi, errs) <- parse GitHub "" file + getRefs fi @?= ["blog", "contacts"] + errs @?= [] ] - , testGroup "\"ignore file\" mode" - [ testCase "Check \"ignore file\" performance" $ do - (fi, errs) <- parse GitHub "tests/markdowns/with-annotations/ignore_file.md" - getRefs fi @?= [] - errs @?= [] + , testGroup "\"ignore all\" mode" + [ testCase "Check \"ignore all\" performance" $ do + let file = mkRelPosixLink $ "tests" FP. "markdowns" FP. "with-annotations" FP. "ignore_file.md" + (fi, errs) <- parse GitHub "" file + getRefs fi @?= [] + errs @?= [] ] ] where getRefs :: FileInfo -> [Text] getRefs fi = map rName $ fi ^. fiReferences - getErrs :: FilePath -> IO [ScanError] - getErrs path = snd <$> parse GitHub path + getErrs :: FilePath -> IO [ScanError 'Parse] + getErrs path = snd <$> parse GitHub "" (mkRelPosixLink path) diff --git a/tests/Test/Xrefcheck/IgnoreRegexSpec.hs b/tests/Test/Xrefcheck/IgnoreRegexSpec.hs --- a/tests/Test/Xrefcheck/IgnoreRegexSpec.hs +++ b/tests/Test/Xrefcheck/IgnoreRegexSpec.hs @@ -5,8 +5,9 @@ module Test.Xrefcheck.IgnoreRegexSpec where -import Universum +import Universum hiding ((.~), (^.)) +import Control.Lens ((.~), (^.)) import Data.Reflection (give) import Data.Yaml (decodeEither') import Test.Tasty (TestTree, testGroup) @@ -16,16 +17,19 @@ import Xrefcheck.Config import Xrefcheck.Core import Xrefcheck.Progress (allowRewrite) -import Xrefcheck.Scan (ScanResult (..), scanRepo, specificFormatsSupport) +import Xrefcheck.Scan import Xrefcheck.Scanners.Markdown +import Xrefcheck.System import Xrefcheck.Util (ColorMode (WithoutColors)) -import Xrefcheck.Verify (VerifyError, VerifyResult, WithReferenceLoc (..), verifyErrors, verifyRepo) +import Xrefcheck.Verify test_ignoreRegex :: TestTree test_ignoreRegex = give WithoutColors $ let root = "tests/markdowns/without-annotations" showProgressBar = False - formats = specificFormatsSupport [markdownSupport defGithubMdConfig] + fileSupport = + give (PrintUnixPaths False) $ + firstFileSupport [markdownSupport defGithubMdConfig] verifyMode = ExternalOnlyMode linksTxt = @@ -39,10 +43,10 @@ in testGroup "Regular expressions performance" [ testCase "Check that only not matched links are verified" $ do scanResult <- allowRewrite showProgressBar $ \rw -> - scanRepo rw formats (config ^. cTraversalL) root + scanRepo OnlyTracked rw fileSupport (config ^. cExclusionsL) root verifyRes <- allowRewrite showProgressBar $ \rw -> - verifyRepo rw (config ^. cVerificationL) verifyMode root $ srRepoInfo scanResult + verifyRepo rw config verifyMode $ srRepoInfo scanResult let brokenLinks = pickBrokenLinks verifyRes @@ -78,13 +82,19 @@ pickBrokenLinks :: VerifyResult (WithReferenceLoc VerifyError) -> [Text] pickBrokenLinks verifyRes = case verifyErrors verifyRes of - Just neWithRefLoc -> map (rLink . wrlReference) $ toList neWithRefLoc + Just neWithRefLoc -> mapMaybe (rUrl . wrlReference) $ toList neWithRefLoc Nothing -> [] + rUrl :: Reference -> Maybe Text + rUrl Reference{..} = + case rInfo of + RIExternal (ELUrl url) -> Just url + _ -> Nothing + linksToRegexs :: [Text] -> [Regex] linksToRegexs links = let errOrRegexs = map (decodeEither' . encodeUtf8) links in map (either (error . show) id) errOrRegexs setIgnoreRefs :: [Regex] -> Config -> Config - setIgnoreRefs regexs = (cVerificationL . vcIgnoreRefsL) .~ regexs + setIgnoreRefs regexs = (cExclusionsL . ecIgnoreExternalRefsToL) .~ regexs diff --git a/tests/Test/Xrefcheck/LocalSpec.hs b/tests/Test/Xrefcheck/LocalSpec.hs deleted file mode 100644 --- a/tests/Test/Xrefcheck/LocalSpec.hs +++ /dev/null @@ -1,25 +0,0 @@ -{- SPDX-FileCopyrightText: 2019 Serokell - - - - SPDX-License-Identifier: MPL-2.0 - -} - -module Test.Xrefcheck.LocalSpec where - -import Universum - -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase, (@?=)) - -import Xrefcheck.Core (canonizeLocalRef) - -test_local_refs_canonizing :: TestTree -test_local_refs_canonizing = testGroup "Local refs canonizing" $ - [ testCase "Strips ./" $ - canonizeLocalRef "./AnchorsSpec.hs" @?= "AnchorsSpec.hs" - - , testCase "Strips ././" $ - canonizeLocalRef "././AnchorsSpec.hs" @?= "AnchorsSpec.hs" - - , testCase "Leaves plain other intact" $ - canonizeLocalRef "../AnchorsSpec.hs" @?= "../AnchorsSpec.hs" - ] diff --git a/tests/Test/Xrefcheck/RedirectChainSpec.hs b/tests/Test/Xrefcheck/RedirectChainSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Xrefcheck/RedirectChainSpec.hs @@ -0,0 +1,162 @@ +{- SPDX-FileCopyrightText: 2022 Serokell + - + - SPDX-License-Identifier: MPL-2.0 + -} + +module Test.Xrefcheck.RedirectChainSpec where + +import Universum hiding ((.~)) + +import Control.Lens ((.~)) +import Data.CaseInsensitive qualified as CI +import Network.HTTP.Types (movedPermanently301) +import Network.HTTP.Types.Header (HeaderName, hLocation) +import Network.Wai qualified as Web +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase) +import Web.Scotty qualified as Web + +import Test.Xrefcheck.UtilRequests +import Xrefcheck.Config +import Xrefcheck.Progress +import Xrefcheck.Verify + +test_redirectRequests :: TestTree +test_redirectRequests = testGroup "Redirect chain tests" + [ testCase "Missing location" $ do + setRef <- newIORef mempty + checkLinkAndProgressWithServer + (configMod 5) + setRef + (5000, mockRedirect) + (link "/broken1") + progress + (VerifyResult [RedirectMissingLocation $ chain [ "/broken1", "/broken2", "/broken3"]]) + , testCase "Cycle" $ do + setRef <- newIORef mempty + checkLinkAndProgressWithServer + (configMod 5) + setRef + (5000, mockRedirect) + (link "/cycle1") + progress + (VerifyResult [RedirectChainCycle $ chain ["/cycle1", "/cycle2", "/cycle3", "/cycle4", "/cycle2"]]) + , testGroup "Relative redirect" + [ testCase "Host" $ do + setRef <- newIORef mempty + checkLinkAndProgressWithServer + (configMod 1) + setRef + (5000, mockRedirect) + (link "/relative/host") + progress + (VerifyResult [RedirectChainLimit $ chain ["/relative/host", "/cycle2", "/cycle3"]]) + , testCase "Path" $ do + setRef <- newIORef mempty + checkLinkAndProgressWithServer + (configMod 1) + setRef + (5000, mockRedirect) + (link "/relative/path") + progress + (VerifyResult [RedirectChainLimit $ chain ["/relative/path", "/relative/host", "/cycle2"]]) + ] + , testCase "Other host redirect" $ withServer (5001, otherMockRedirect) $ do + setRef <- newIORef mempty + checkLinkAndProgressWithServer + (configMod 1) + setRef + (5000, mockRedirect) + "http://127.0.0.1:5001/other/host" + progress + (VerifyResult [RedirectChainLimit $ fromList ["http://127.0.0.1:5001/other/host", link "/relative/host", link "/cycle2"]]) + , testGroup "Limit" + [ testCase "Takes effect" $ do + setRef <- newIORef mempty + checkLinkAndProgressWithServer + (configMod 2) + setRef + (5000, mockRedirect) + (link "/cycle1") + progress + (VerifyResult [RedirectChainLimit $ chain ["/cycle1", "/cycle2", "/cycle3", "/cycle4"]]) + , testCase "No redirects allowed" $ do + setRef <- newIORef mempty + checkLinkAndProgressWithServer + (configMod 0) + setRef + (5000, mockRedirect) + (link "/cycle1") + progress + (VerifyResult [RedirectChainLimit $ chain ["/cycle1", "/cycle2"]]) + , testCase "Negative" $ do + setRef <- newIORef mempty + checkLinkAndProgressWithServer + (configMod (-1)) + setRef + (5000, mockRedirect) + (link "/cycle1") + progress + (VerifyResult [RedirectChainCycle $ chain ["/cycle1", "/cycle2", "/cycle3", "/cycle4", "/cycle2"]]) + ] + ] + where + link :: Text -> Text + link = ("http://127.0.0.1:5000" <>) + + chain :: [Text] -> RedirectChain + chain = fromList . fmap link + + progress :: Progress Int Text + progress = reportError "" $ initProgress 1 + + configMod :: Int -> Config -> Config + configMod limit config = config + & cNetworkingL . ncExternalRefRedirectsL .~ [RedirectRule Nothing Nothing Nothing RROFollow] + & cNetworkingL . ncMaxRedirectFollowsL .~ limit + + setHeader :: HeaderName -> Text -> Web.ActionM () + setHeader hdr value = Web.setHeader (decodeUtf8 (CI.original hdr)) (fromStrict value) + + mockRedirect :: IO Web.Application + mockRedirect = do + Web.scottyApp $ do + -- A set of redirect routes that correspond to a broken chain. + Web.matchAny "/broken1" $ do + setHeader hLocation (link "/broken2") + Web.status movedPermanently301 + Web.matchAny "/broken2" $ do + setHeader hLocation (link "/broken3") + Web.status movedPermanently301 + Web.matchAny "/broken3" $ do + -- hLocation: no value + Web.status movedPermanently301 + + -- A set of redirect routes that correspond to a cycle. + Web.matchAny "/cycle1" $ do + setHeader hLocation (link "/cycle2") + Web.status movedPermanently301 + Web.matchAny "/cycle2" $ do + setHeader hLocation (link "/cycle3") + Web.status movedPermanently301 + Web.matchAny "/cycle3" $ do + setHeader hLocation (link "/cycle4") + Web.status movedPermanently301 + Web.matchAny "/cycle4" $ do + setHeader hLocation (link "/cycle2") + Web.status movedPermanently301 + + -- Relative redirects. + Web.matchAny "/relative/host" $ do + setHeader hLocation "/cycle2" + Web.status movedPermanently301 + Web.matchAny "/relative/path" $ do + setHeader hLocation "host" + Web.status movedPermanently301 + + -- To other host + otherMockRedirect :: IO Web.Application + otherMockRedirect = + Web.scottyApp $ Web.matchAny "/other/host" $ do + setHeader hLocation (link "/relative/host") + Web.status movedPermanently301 diff --git a/tests/Test/Xrefcheck/RedirectConfigSpec.hs b/tests/Test/Xrefcheck/RedirectConfigSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Xrefcheck/RedirectConfigSpec.hs @@ -0,0 +1,193 @@ +{- SPDX-FileCopyrightText: 2022 Serokell + - + - SPDX-License-Identifier: MPL-2.0 + -} + +module Test.Xrefcheck.RedirectConfigSpec where + +import Universum hiding ((%~), (.~)) + +import Control.Lens ((%~), (.~)) +import Data.CaseInsensitive qualified as CI +import Network.HTTP.Types (found302, movedPermanently301, temporaryRedirect307) +import Network.HTTP.Types.Header (HeaderName, hLocation) +import Network.Wai qualified as Web +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase) +import Text.Regex.TDFA.Text qualified as R +import Web.Scotty qualified as Web + +import Test.Xrefcheck.UtilRequests +import Xrefcheck.Config +import Xrefcheck.Progress +import Xrefcheck.Scan +import Xrefcheck.Verify + +test_redirectRequests :: TestTree +test_redirectRequests = testGroup "Redirect config tests" + [ testGroup "Match" + [ testGroup "By \"on\"" + [ testCase "Do match" $ do + setRef <- newIORef mempty + checkLinkAndProgressWithServer + (configMod [RedirectRule Nothing Nothing (Just RROTemporary) RROInvalid] []) + setRef + (5000, mockRedirect) + (link "/temporary-redirect") + (progress False) + (VerifyResult [RedirectRuleError (chain ["/temporary-redirect", "/ok"]) (Just RROTemporary)]) + , testCase "Do not match" $ do + setRef <- newIORef mempty + checkLinkAndProgressWithServer + (configMod [RedirectRule Nothing Nothing (Just RROPermanent) RROInvalid] []) + setRef + (5000, mockRedirect) + (link "/temporary-redirect") + (progress True) + (VerifyResult []) + ] + , testGroup "By \"to\"" + [ testCase "Do match" $ do + setRef <- newIORef mempty + checkLinkAndProgressWithServer + (configMod [RedirectRule Nothing (regex ".*/ok") Nothing RROValid] []) + setRef + (5000, mockRedirect) + (link "/permanent-redirect") + (progress True) + (VerifyResult []) + , testCase "Do not match" $ do + setRef <- newIORef mempty + checkLinkAndProgressWithServer + (configMod [RedirectRule Nothing (regex ".*/no-ok") (Just RROPermanent) RROValid] []) + setRef + (5000, mockRedirect) + (link "/permanent-redirect") + (progress False) + (VerifyResult [RedirectRuleError (chain ["/permanent-redirect", "/ok"]) (Just RROPermanent)]) + ] + , testGroup "By \"from\"" + [ testCase "Do match" $ do + setRef <- newIORef mempty + checkLinkAndProgressWithServer + (configMod [RedirectRule (regex ".*/permanent-.*") Nothing Nothing RROValid] []) + setRef + (5000, mockRedirect) + (link "/permanent-redirect") + (progress True) + (VerifyResult []) + , testCase "Do not match" $ do + setRef <- newIORef mempty + checkLinkAndProgressWithServer + (configMod [RedirectRule (regex ".*/temporary-.*") Nothing (Just RROPermanent) RROValid] []) + setRef + (5000, mockRedirect) + (link "/permanent-redirect") + (progress False) + (VerifyResult [RedirectRuleError (chain ["/permanent-redirect", "/ok"]) (Just RROPermanent)]) + ] + , testGroup "By \"from\", \"to\" and \"on\"" + [ testCase "Do match" $ do + setRef <- newIORef mempty + checkLinkAndProgressWithServer + (configMod [RedirectRule (regex ".*/follow[0-9]") (regex "^.*/ok$") (Just (RROCode 307)) RROInvalid] []) + setRef + (5000, mockRedirect) + (link "/follow3") + (progress False) + (VerifyResult [RedirectRuleError (chain ["/follow3", "/ok"]) (Just (RROCode 307))]) + , testCase "Do not match" $ do + setRef <- newIORef mempty + checkLinkAndProgressWithServer + (configMod [RedirectRule (regex ".*/follow[0-9]") (regex "^.*/ok$") (Just (RROCode 307)) RROInvalid] []) + setRef + (5000, mockRedirect) + (link "/follow2") + (progress True) + (VerifyResult []) + ] + , testCase "By any" $ do + setRef <- newIORef mempty + checkLinkAndProgressWithServer + (configMod [RedirectRule Nothing Nothing Nothing RROValid] []) + setRef + (5000, mockRedirect) + (link "/follow1") + (progress True) + (VerifyResult []) + ] + , testGroup "Chain" + [ testCase "End valid" $ do + setRef <- newIORef mempty + checkLinkAndProgressWithServer + (configMod [RedirectRule Nothing Nothing Nothing RROFollow] []) + setRef + (5000, mockRedirect) + (link "/follow1") + (progress True) + (VerifyResult []) + , testCase "End invalid" $ do + setRef <- newIORef mempty + checkLinkAndProgressWithServer + (configMod [RedirectRule Nothing Nothing (Just (RROCode 307)) RROInvalid, RedirectRule Nothing Nothing Nothing RROFollow] []) + setRef + (5000, mockRedirect) + (link "/follow1") + (progress False) + (VerifyResult [RedirectRuleError (chain ["/follow1", "/follow2", "/follow3", "/ok"]) (Just (RROCode 307))]) + , testCase "Mixed with ignore" $ do + setRef <- newIORef mempty + checkLinkAndProgressWithServer + (configMod [RedirectRule Nothing Nothing (Just (RROCode 307)) RROInvalid, RedirectRule Nothing Nothing Nothing RROFollow] (maybeToList (regex ".*/follow3"))) + setRef + (5000, mockRedirect) + (link "/follow1") + (progress True) + (VerifyResult []) + ] + ] + where + link :: Text -> Text + link = ("http://127.0.0.1:5000" <>) + + chain :: [Text] -> RedirectChain + chain = fromList . fmap link + + regex :: Text -> Maybe R.Regex + regex = rightToMaybe . R.compile defaultCompOption defaultExecOption + + configMod :: [RedirectRule] -> [R.Regex] -> Config -> Config + configMod rules exclussions config = config + & cNetworkingL . ncExternalRefRedirectsL %~ (rules <>) + & cExclusionsL . ecIgnoreExternalRefsToL .~ exclussions + + setHeader :: HeaderName -> Text -> Web.ActionM () + setHeader hdr value = Web.setHeader (decodeUtf8 (CI.original hdr)) (fromStrict value) + + progress :: Bool -> Progress Int Text + progress shouldSucceed = report "" $ initProgress 1 + where + report = + if shouldSucceed + then reportSuccess + else reportError + + mockRedirect :: IO Web.Application + mockRedirect = + Web.scottyApp $ do + Web.matchAny "/ok" $ Web.raw "Ok" + Web.matchAny "/permanent-redirect" $ do + setHeader hLocation "/ok" + Web.status movedPermanently301 + Web.matchAny "/temporary-redirect" $ do + setHeader hLocation "/ok" + Web.status found302 + Web.matchAny "/follow1" $ do + setHeader hLocation "/follow2" + Web.status movedPermanently301 + Web.matchAny "/follow2" $ do + setHeader hLocation "/follow3" + Web.status found302 + Web.matchAny "/follow3" $ do + setHeader hLocation "/ok" + Web.status temporaryRedirect307 diff --git a/tests/Test/Xrefcheck/RedirectDefaultSpec.hs b/tests/Test/Xrefcheck/RedirectDefaultSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Xrefcheck/RedirectDefaultSpec.hs @@ -0,0 +1,86 @@ +{- SPDX-FileCopyrightText: 2022 Serokell + - + - SPDX-License-Identifier: MPL-2.0 + -} + +module Test.Xrefcheck.RedirectDefaultSpec where + +import Universum + +import Data.CaseInsensitive qualified as CI +import Data.Set qualified as S +import Network.HTTP.Types (Status, mkStatus) +import Network.HTTP.Types.Header (HeaderName, hLocation) +import Network.Wai qualified as Web +import Test.Tasty (TestName, TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, testCase) +import Web.Scotty qualified as Web + +import Test.Xrefcheck.UtilRequests +import Xrefcheck.Config +import Xrefcheck.Progress +import Xrefcheck.Verify + +test_redirectRequests :: TestTree +test_redirectRequests = testGroup "Redirect response defaults" + [ testGroup "Temporary" $ allowedRedirectTests <$> [302, 303, 307] + , testGroup "Permanent" $ permanentRedirectTests <$> [301, 308] + , testGroup "304 Not Modified" $ allowedRedirectTests <$> [304] + ] + where + url :: Text + url = "http://127.0.0.1:5000/redirect" + + location :: Maybe Text + location = Just "http://127.0.0.1:5000/other" + + allowedRedirectTests :: Int -> TestTree + allowedRedirectTests statusCode = + redirectTests + (show statusCode <> " passes by default") + (mkStatus statusCode "Allowed redirect") + (\case + Nothing -> Just $ RedirectMissingLocation $ fromList [url] + Just _ -> Nothing + ) + + permanentRedirectTests :: Int -> TestTree + permanentRedirectTests statusCode = + redirectTests + (show statusCode <> " fails by default") + (mkStatus statusCode "Permanent redirect") + (\case + Nothing -> Just $ RedirectMissingLocation $ fromList [url] + Just loc -> Just $ RedirectRuleError (fromList [url, loc]) (Just RROPermanent) + ) + + redirectTests :: TestName -> Status -> (Maybe Text -> Maybe VerifyError) -> TestTree + redirectTests name expectedStatus expectedError = + testGroup name + [ + testCase "With no location" $ + redirectAssertion expectedStatus Nothing (expectedError Nothing), + testCase "With location" $ + redirectAssertion expectedStatus location (expectedError location) + ] + + redirectAssertion :: Status -> Maybe Text -> Maybe VerifyError -> Assertion + redirectAssertion expectedStatus expectedLocation expectedError = do + setRef <- newIORef S.empty + checkLinkAndProgressWithServerDefault + setRef + (5000, mockRedirect expectedLocation expectedStatus) + url + ( (if isNothing expectedError then reportSuccess else reportError) "" $ + initProgress 1 + ) + (VerifyResult $ maybeToList expectedError) + + mockRedirect :: Maybe Text -> Status -> IO Web.Application + mockRedirect expectedLocation expectedStatus = + Web.scottyApp $ Web.matchAny "/redirect" $ do + whenJust expectedLocation (setHeader hLocation) + Web.status expectedStatus + + setHeader :: HeaderName -> Text -> Web.ActionM () + setHeader hdr value = Web.setHeader (decodeUtf8 (CI.original hdr)) (fromStrict value) diff --git a/tests/Test/Xrefcheck/TimeoutSpec.hs b/tests/Test/Xrefcheck/TimeoutSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Xrefcheck/TimeoutSpec.hs @@ -0,0 +1,146 @@ +{- SPDX-FileCopyrightText: 2021 Serokell + - + - SPDX-License-Identifier: MPL-2.0 + -} + +module Test.Xrefcheck.TimeoutSpec where + +import Universum hiding ((.~)) + +import Control.Lens ((.~)) +import Data.CaseInsensitive qualified as CI +import Data.Set qualified as S +import Network.HTTP.Types (ok200, tooManyRequests429) +import Network.HTTP.Types.Header (HeaderName, hRetryAfter) +import Network.Wai qualified as Web +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase) +import Time (Second, Time, sec, threadDelay) +import Web.Scotty qualified as Web + +import Test.Xrefcheck.UtilRequests +import Xrefcheck.Config +import Xrefcheck.Progress +import Xrefcheck.Verify + +-- Here all the delays are doubled because we call sites +-- with HEAD first and then GET methods. +test_timeout :: TestTree +test_timeout = testGroup "Timeout tests" + [ testCase "Succeeds on one timeout if there were no 429 responses and no retries allowed" $ + timeoutTestCase [Delay] True + (cNetworkingL . ncMaxTimeoutRetriesL .~ 0) + , testCase "Returns an error on two timeouts if there were no 429 responses" $ + timeoutTestCase [Delay, Delay] False + (cNetworkingL . ncMaxTimeoutRetriesL .~ 2) + , testCase "Returns an error if there were 429 but no timeouts allowed" $ + timeoutTestCase [Respond429, Delay, Delay] False + (cNetworkingL . ncMaxTimeoutRetriesL .~ 0) + , testCase "Succeeds if there were 429 and one timeout allowed" $ + timeoutTestCase [Respond429, Delay, Delay] True + (cNetworkingL . ncMaxTimeoutRetriesL .~ 1) + , testCase "Fails on second timeout if there were 429 and one timeout allowed" $ + timeoutTestCase [Respond429, Delay, Delay, Delay, Delay] False + (cNetworkingL . ncMaxTimeoutRetriesL .~ 1) + , testCase "Fails on maximum allowed errors achieved (mixed errors)" $ + timeoutTestCase [Respond429, Delay, Delay, Respond429, Delay, Delay] False $ \c -> c + & cNetworkingL . ncMaxTimeoutRetriesL .~ 3 + & cNetworkingL . ncMaxRetriesL .~ 3 + , testCase "Fails on timeout if another domain returned 429" $ do + setRef <- newIORef S.empty + checkMultipleLinksWithServer + (5000, mockTimeout (sec 0.4) [Respond429, Ok, Delay, Delay]) + setRef + [ VerifyLinkTestEntry + { vlteConfigModifier = \c -> c + & cNetworkingL . ncMaxRetriesL .~ 1 + & setAllowedTimeout + , vlteLink = "http://127.0.0.1:5000/timeout" + , vlteExpectedProgress = mkProgressWithOneTask True + , vlteExpectationErrors = VerifyResult [] + } + , VerifyLinkTestEntry + { vlteConfigModifier = \c -> c + & cNetworkingL . ncMaxTimeoutRetriesL .~ 0 + & setAllowedTimeout + , vlteLink = "http://localhost:5000/timeout" + , vlteExpectedProgress = mkProgressWithOneTask False + , vlteExpectationErrors = VerifyResult + [ ExternalHttpTimeout (Just $ DomainName "localhost") + ] + } + ] + , testCase "Succeeds on timeout if another path of this domain returned 429" $ do + setRef <- newIORef S.empty + checkMultipleLinksWithServer + (5000, mockTimeout (sec 0.4) [Respond429, Ok, Delay, Delay]) + setRef + [ VerifyLinkTestEntry + { vlteConfigModifier = \c -> c + & cNetworkingL . ncMaxRetriesL .~ 1 + & setAllowedTimeout + , vlteLink = "http://127.0.0.1:5000/timeout" + , vlteExpectedProgress = mkProgressWithOneTask True + , vlteExpectationErrors = VerifyResult [] + } + , VerifyLinkTestEntry + { vlteConfigModifier = \c -> c + & cNetworkingL . ncMaxTimeoutRetriesL .~ 1 + & setAllowedTimeout + , vlteLink = "http://127.0.0.1:5000/timeoutother" + , vlteExpectedProgress = mkProgressWithOneTask True + , vlteExpectationErrors = VerifyResult [] + } + ] + ] + where + setAllowedTimeout = cNetworkingL . ncExternalRefCheckTimeoutL .~ (sec 0.25) + + mkProgressWithOneTask shouldSucceed = report "" $ initProgress 1 + where + report = + if shouldSucceed + then reportSuccess + else reportError + + timeoutTestCase mockResponses shouldSucceed configModifier = do + let prog = mkProgressWithOneTask shouldSucceed + setRef <- newIORef S.empty + checkLinkAndProgressWithServer + (\c -> c + & setAllowedTimeout + & configModifier) + setRef + (5000, mockTimeout (sec 0.4) mockResponses) + "http://127.0.0.1:5000/timeout" prog $ + VerifyResult $ + [ExternalHttpTimeout $ Just (DomainName "127.0.0.1") | not shouldSucceed] + + -- When called for the first (N-1) times, waits for specified + -- amount of seconds and returns an arbitrary result. + -- When called N time returns the result immediately. + mockTimeout :: Time Second -> [MockTimeoutBehaviour] -> IO Web.Application + mockTimeout timeout behList = do + ref <- newIORef @_ behList + Web.scottyApp $ do + Web.matchAny "/timeout" $ handler ref + Web.matchAny "/timeoutother" $ handler ref + where + handler ref = do + mbCurrentAction <- atomicModifyIORef' ref $ \case + b : bs -> (bs, Just b) + [] -> ([], Nothing) + case mbCurrentAction of + Nothing -> Web.status ok200 + Just Ok -> Web.status ok200 + Just Delay -> do + threadDelay timeout + Web.status ok200 + Just Respond429 -> do + setHeader hRetryAfter "1" + Web.status tooManyRequests429 + + setHeader :: HeaderName -> Text -> Web.ActionM () + setHeader hdr value = Web.setHeader (decodeUtf8 (CI.original hdr)) (fromStrict value) + +data MockTimeoutBehaviour = Respond429 | Delay | Ok diff --git a/tests/Test/Xrefcheck/TooManyRequestsSpec.hs b/tests/Test/Xrefcheck/TooManyRequestsSpec.hs --- a/tests/Test/Xrefcheck/TooManyRequestsSpec.hs +++ b/tests/Test/Xrefcheck/TooManyRequestsSpec.hs @@ -7,21 +7,20 @@ import Universum -import Control.Concurrent (forkIO, killThread) -import Control.Exception qualified as E import Data.CaseInsensitive qualified as CI -import Data.Map qualified as M +import Data.Set qualified as S import Data.Time (addUTCTime, defaultTimeLocale, formatTime, getCurrentTime, rfc822DateFormat) import Data.Time.Clock.POSIX (getPOSIXTime) -import Fmt (indentF, pretty, unlinesF) import Network.HTTP.Types (Status (..), ok200, serviceUnavailable503, tooManyRequests429) -import Network.HTTP.Types.Header (hRetryAfter) +import Network.HTTP.Types.Header (HeaderName, hRetryAfter) +import Network.Wai (requestMethod) +import Network.Wai qualified as Web import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, testCase, (@?=)) import Time (sec, (-:-)) -import Web.Firefly (ToResponse (toResponse), getMethod, route, run) +import Web.Scotty qualified as Web -import Xrefcheck.Config +import Test.Xrefcheck.UtilRequests import Xrefcheck.Core import Xrefcheck.Progress import Xrefcheck.Util @@ -30,44 +29,34 @@ test_tooManyRequests :: TestTree test_tooManyRequests = testGroup "429 response tests" [ testCase "Returns 200 eventually" $ do - let prog = Progress{ pTotal = 1 - , pCurrent = 1 - , pErrorsUnfixable = 0 - , pErrorsFixable = 0 - , pTaskTimestamp = Nothing - } - checkLinkAndProgressWithServer (mock429 "1" ok200) + setRef <- newIORef S.empty + let prog = reportSuccess "" $ initProgress 1 + checkLinkAndProgressWithServerDefault setRef (5000, mock429 "1" ok200) "http://127.0.0.1:5000/429" prog $ VerifyResult [] , testCase "Returns 503 eventually" $ do - let prog = Progress{ pTotal = 1 - , pCurrent = 1 - , pErrorsUnfixable = 1 - , pErrorsFixable = 0 - , pTaskTimestamp = Nothing - } - checkLinkAndProgressWithServer (mock429 "1" serviceUnavailable503) + setRef <- newIORef S.empty + let prog = reportError "" $ initProgress 1 + checkLinkAndProgressWithServerDefault setRef (5000, mock429 "1" serviceUnavailable503) "http://127.0.0.1:5000/429" prog $ VerifyResult [ ExternalHttpResourceUnavailable $ Status { statusCode = 503, statusMessage = "Service Unavailable"} ] , testCase "Successfully updates the new retry-after value (as seconds)" $ do - E.bracket (forkIO $ mock429 "2" ok200) killThread $ \_ -> do + withServer (5000, mock429 "2" ok200) $ do now <- getPOSIXTime <&> posixTimeToTimeSecond + setRef <- newIORef S.empty progressRef <- newIORef VerifyProgress { vrLocal = initProgress 0 - , vrExternal = Progress - { pTotal = 2 - , pCurrent = 1 - , pErrorsUnfixable = 0 - , pErrorsFixable = 0 - , pTaskTimestamp = Just (TaskTimestamp (sec 3) (now -:- sec 1.5)) - } + , vrExternal = setTaskTimestamp "" (sec 3) (now -:- sec 1.5) + . reportSuccess "" + $ initProgress 2 } - _ <- verifyReferenceWithProgress - (Reference "" "http://127.0.0.1:5000/429" Nothing (Position Nothing)) + _ <- verifyReferenceWithProgressDefault + (Reference "" (Position "") $ RIExternal $ ELUrl "http://127.0.0.1:5000/429") + setRef progressRef - Progress{..} <- vrExternal <$> readIORef progressRef - let ttc = ttTimeToCompletion <$> pTaskTimestamp + progress <- vrExternal <$> readIORef progressRef + let ttc = ttTimeToCompletion <$> getTaskTimestamp progress flip assertBool (ttc == Just (sec 2)) $ "Expected time to completion be equal to " ++ show (Just $ sec 2) ++ ", but instead it's " ++ show ttc @@ -77,22 +66,20 @@ -- Set the @Retry-After@ response header value as (current datetime + 4 seconds) retryAfter = formatTime defaultTimeLocale rfc822DateFormat (addUTCTime 4 utctime) now = utcTimeToTimeSecond utctime - E.bracket (forkIO $ mock429 (fromString retryAfter) ok200) killThread $ \_ -> do + withServer (5000, mock429 (fromString retryAfter) ok200) $ do + setRef <- newIORef S.empty progressRef <- newIORef VerifyProgress { vrLocal = initProgress 0 - , vrExternal = Progress - { pTotal = 2 - , pCurrent = 1 - , pErrorsUnfixable = 0 - , pErrorsFixable = 0 - , pTaskTimestamp = Just (TaskTimestamp (sec 2) (now -:- sec 1.5)) - } + , vrExternal = setTaskTimestamp "" (sec 2) (now -:- sec 1.5) + . reportSuccess "" + $ initProgress 2 } - _ <- verifyReferenceWithProgress - (Reference "" "http://127.0.0.1:5000/429" Nothing (Position Nothing)) + _ <- verifyReferenceWithProgressDefault + (Reference "" (Position "") $ RIExternal $ ELUrl "http://127.0.0.1:5000/429") + setRef progressRef - Progress{..} <- vrExternal <$> readIORef progressRef - let ttc = fromMaybe (sec 0) $ ttTimeToCompletion <$> pTaskTimestamp + progress <- vrExternal <$> readIORef progressRef + let ttc = fromMaybe (sec 0) $ ttTimeToCompletion <$> getTaskTimestamp progress flip assertBool (sec 3 <= ttc && ttc <= sec 4) $ "Expected time to completion be within range (seconds): 3 <= x <= 4" ++ ", but instead it's " ++ show ttc @@ -103,33 +90,32 @@ -- Set the @Retry-After@ response header value as (current datetime - 4 seconds) retryAfter = formatTime defaultTimeLocale rfc822DateFormat (addUTCTime (-4) utctime) now = utcTimeToTimeSecond utctime - E.bracket (forkIO $ mock429 (fromString retryAfter) ok200) killThread $ \_ -> do + withServer (5000, mock429 (fromString retryAfter) ok200) $ do + setRef <- newIORef S.empty progressRef <- newIORef VerifyProgress { vrLocal = initProgress 0 - , vrExternal = Progress - { pTotal = 2 - , pCurrent = 1 - , pErrorsUnfixable = 0 - , pErrorsFixable = 0 - , pTaskTimestamp = Just (TaskTimestamp (sec 1) (now -:- sec 1.5)) - } + , vrExternal = setTaskTimestamp "" (sec 1) (now -:- sec 1.5) + . reportSuccess "" + $ initProgress 2 } - _ <- verifyReferenceWithProgress - (Reference "" "http://127.0.0.1:5000/429" Nothing (Position Nothing)) + _ <- verifyReferenceWithProgressDefault + (Reference "" (Position "") $ RIExternal $ ELUrl "http://127.0.0.1:5000/429") + setRef progressRef - Progress{..} <- vrExternal <$> readIORef progressRef - let ttc = ttTimeToCompletion <$> pTaskTimestamp + progress <- vrExternal <$> readIORef progressRef + let ttc = ttTimeToCompletion <$> getTaskTimestamp progress flip assertBool (ttc == Just (sec 0)) $ "Expected time to completion be 0 seconds" ++ ", but instead it's " ++ show ttc , testCase "The GET request should not be attempted after catching a 429" $ do let - mock429WithGlobalIORef :: IORef [(Text, Status)] -> IO () + mock429WithGlobalIORef :: IORef [(Text, Status)] -> IO Web.Application mock429WithGlobalIORef infoReverseAccumulatorRef = do callCountRef <- newIORef @_ @Int 0 - run 5000 $ do - route "/429grandfinale" $ do - m <- getMethod + Web.scottyApp $ + Web.matchAny "/429grandfinale" $ do + req <- Web.request + let m = decodeUtf8 (requestMethod req) callCount <- atomicModifyIORef' callCountRef $ \cc -> (cc + 1, cc) atomicModifyIORef' infoReverseAccumulatorRef $ \lst -> ( ( m @@ -139,17 +125,16 @@ ) : lst , () ) - pure $ if - | m == "GET" -> toResponse ("" :: Text, ok200) - | callCount == 0 -> toResponse - ( "" :: Text - , tooManyRequests429 - , M.fromList [(CI.map (decodeUtf8 @Text) hRetryAfter, ["1" :: Text])] - ) - | otherwise -> toResponse ("" :: Text, serviceUnavailable503) + if + | m == "GET" -> Web.status ok200 + | callCount == 0 -> do + Web.status tooManyRequests429 + setHeader hRetryAfter "1" + | otherwise -> Web.status serviceUnavailable503 infoReverseAccumulatorRef <- newIORef [] - E.bracket (forkIO $ mock429WithGlobalIORef infoReverseAccumulatorRef) killThread $ \_ -> do - _ <- verifyLink "http://127.0.0.1:5000/429grandfinale" + setRef <- newIORef S.empty + withServer (5000, mock429WithGlobalIORef infoReverseAccumulatorRef) $ do + _ <- verifyLinkDefault setRef "http://127.0.0.1:5000/429grandfinale" infoReverseAccumulator <- readIORef infoReverseAccumulatorRef reverse infoReverseAccumulator @?= [ ("HEAD", tooManyRequests429) @@ -158,61 +143,20 @@ ] ] where - checkLinkAndProgressWithServer mock link progress vrExpectation = - E.bracket (forkIO mock) killThread $ \_ -> do - (result, progRes) <- verifyLink link - flip assertBool (result == vrExpectation) . pretty $ unlinesF - [ "Verification results differ: expected" - , indentF 2 (show vrExpectation) - , "but got" - , indentF 2 (show result) - ] - flip assertBool (progRes `progEquiv` progress) . pretty $ unlinesF - [ "Expected the progress bar state to be" - , indentF 2 (show progress) - , "but got" - , indentF 2 (show progRes) - ] - where - -- | Check whether the two @Progress@ values are equal up to similarity of their essential - -- components, ignoring the comparison of @pTaskTimestamp@s, which is done to prevent test - -- failures when comparing the resulting progress, gotten from running the link - -- verification algorithm, with the expected one, where @pTaskTimestamp@ is hardcoded - -- as @Nothing@. - progEquiv :: Eq a => Progress a -> Progress a -> Bool - progEquiv p1 p2 = and [ ((==) `on` pCurrent) p1 p2 - , ((==) `on` pTotal) p1 p2 - , ((==) `on` pErrorsUnfixable) p1 p2 - , ((==) `on` pErrorsFixable) p1 p2 - ] - - verifyLink :: Text -> IO (VerifyResult VerifyError, Progress Int) - verifyLink link = do - let reference = Reference "" link Nothing (Position Nothing) - progRef <- newIORef $ initVerifyProgress [reference] - result <- verifyReferenceWithProgress reference progRef - progress <- readIORef progRef - return (result, vrExternal progress) - - verifyReferenceWithProgress :: Reference -> IORef VerifyProgress -> IO (VerifyResult VerifyError) - verifyReferenceWithProgress reference progRef = do - fmap wrlItem <$> verifyReference - ((cVerification $ defConfig GitHub) { vcIgnoreRefs = [] }) FullMode - progRef (RepoInfo M.empty mempty) "." "" reference - - -- | When called for the first time, returns with a 429 and `Retry-After: @retryAfter@`. + -- When called for the first time, returns with a 429 and `Retry-After: @retryAfter@`. -- Subsequent calls will respond with @status@. - mock429 :: Text -> Status -> IO () + mock429 :: Text -> Status -> IO Web.Application mock429 retryAfter status = do callCountRef <- newIORef @_ @Int 0 - run 5000 $ - route "/429" $ do + Web.scottyApp $ + Web.matchAny "/429" $ do callCount <- atomicModifyIORef' callCountRef $ \cc -> (cc + 1, cc) - pure $ - if callCount == 0 - then toResponse - ( "" :: Text - , tooManyRequests429 - , M.fromList [(CI.map (decodeUtf8 @Text) hRetryAfter, [retryAfter])] - ) - else toResponse ("" :: Text, status) + if callCount == 0 + then do + setHeader hRetryAfter retryAfter + Web.status tooManyRequests429 + else do + Web.status status + + setHeader :: HeaderName -> Text -> Web.ActionM () + setHeader hdr value = Web.setHeader (decodeUtf8 (CI.original hdr)) (fromStrict value) diff --git a/tests/Test/Xrefcheck/TrailingSlashSpec.hs b/tests/Test/Xrefcheck/TrailingSlashSpec.hs --- a/tests/Test/Xrefcheck/TrailingSlashSpec.hs +++ b/tests/Test/Xrefcheck/TrailingSlashSpec.hs @@ -5,40 +5,46 @@ module Test.Xrefcheck.TrailingSlashSpec where -import Universum +import Universum hiding ((.~)) -import Fmt (blockListF, pretty, unlinesF) +import Control.Lens ((.~)) +import Data.Reflection (give) import System.Directory (doesFileExist) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertFailure, testCase) +import Text.Interpolation.Nyan import Xrefcheck.Config import Xrefcheck.Core import Xrefcheck.Progress import Xrefcheck.Scan import Xrefcheck.Scanners.Markdown +import Xrefcheck.System +import Xrefcheck.Util test_slash :: TestTree test_slash = testGroup "Trailing forward slash detection" $ let config = defConfig GitHub - format = specificFormatsSupport [markdownSupport (scMarkdown (cScanners config))] + fileSupport = + give (PrintUnixPaths False) $ + firstFileSupport [markdownSupport (scMarkdown (cScanners config))] in roots <&> \root -> testCase ("All the files within the root \"" <> root <> "\" should exist") $ do - (ScanResult _ (RepoInfo repoInfo _)) <- allowRewrite False $ \rw -> - scanRepo rw format TraversalConfig{ tcIgnored = [] } root - nonExistentFiles <- lefts <$> forM (keys repoInfo) (\filePath -> do - predicate <- doesFileExist filePath + (ScanResult _ RepoInfo{..}) <- allowRewrite False $ \rw -> + scanRepo OnlyTracked rw fileSupport (cExclusions config & ecIgnoreL .~ []) root + nonExistentFiles <- lefts <$> forM (fst . snd <$> toPairs riFiles) (\file -> do + predicate <- doesFileExist . filePathFromRoot root $ file return $ if predicate then Right () - else Left filePath) - if null nonExistentFiles - then pass - else assertFailure $ pretty $ unlinesF - [ "Expected all filepaths to be valid, but these filepaths do not exist:" - , blockListF nonExistentFiles - ] + else Left . filePathFromRoot root $ file) + whenJust (nonEmpty nonExistentFiles) $ \files -> + assertFailure + [int|| + Expected all filepaths to be valid, but these filepaths do not exist: + #{interpolateBlockListF files} + |] where roots :: [FilePath] roots = diff --git a/tests/Test/Xrefcheck/URIParsingSpec.hs b/tests/Test/Xrefcheck/URIParsingSpec.hs --- a/tests/Test/Xrefcheck/URIParsingSpec.hs +++ b/tests/Test/Xrefcheck/URIParsingSpec.hs @@ -3,8 +3,6 @@ - SPDX-License-Identifier: MPL-2.0 -} -{-# LANGUAGE QuasiQuotes #-} - module Test.Xrefcheck.URIParsingSpec where import Universum @@ -13,9 +11,9 @@ import Test.Tasty.HUnit (testCase, (@?=)) import Text.URI (URI) import Text.URI.QQ (uri) -import URI.ByteString (SchemaError (..), URIParseError (..)) +import URI.ByteString qualified as URIBS -import Xrefcheck.Verify (VerifyError (..), parseUri) +import Xrefcheck.Data.URI (UriParseError (..), parseUri) test_uri :: [TestTree] test_uri = @@ -38,20 +36,20 @@ , testGroup "URI parsing should be unsuccessful" [ testCase "With the special characters anywhere else" do parseUri' "https://exam/?q=a&p=b#fra{g}ment" >>= - (@?= Left (ExternalResourceInvalidUri MalformedPath)) + (@?= Left (UPEInvalid URIBS.MalformedPath)) parseUri' "https://example.com/pa[t]h/to[/]smth?q=a&p=b" >>= - (@?= Left (ExternalResourceInvalidUri MalformedPath)) + (@?= Left (UPEInvalid URIBS.MalformedPath)) , testCase "With malformed scheme" do parseUri' "https//example.com/" >>= - (@?= Left (ExternalResourceInvalidUri $ MalformedScheme MissingColon)) + (@?= Left (UPEInvalid $ URIBS.MalformedScheme URIBS.MissingColon)) , testCase "With malformed fragment" do parseUri' "https://example.com/?q=a&p=b#fra{g}ment" >>= - (@?= Left (ExternalResourceInvalidUri MalformedFragment)) + (@?= Left (UPEInvalid URIBS.MalformedFragment)) ] ] where - parseUri' :: Text -> IO $ Either VerifyError URI - parseUri' = runExceptT . parseUri + parseUri' :: Text -> IO $ Either UriParseError URI + parseUri' = runExceptT . parseUri False diff --git a/tests/Test/Xrefcheck/Util.hs b/tests/Test/Xrefcheck/Util.hs --- a/tests/Test/Xrefcheck/Util.hs +++ b/tests/Test/Xrefcheck/Util.hs @@ -7,17 +7,49 @@ import Universum +import Data.Reflection (give) +import Data.Tagged (untag) import Network.HTTP.Types (forbidden403, unauthorized401) -import Web.Firefly (ToResponse (..), route, run) +import Network.Wai.Handler.Warp qualified as Web +import Options.Applicative (auto, help, long, option) +import Test.Tasty.Options as Tasty (IsOption (..), OptionDescription (Option), safeRead) +import Web.Scotty qualified as Web -import Xrefcheck.Core (FileInfo, Flavor) -import Xrefcheck.Scan (ScanError) +import Xrefcheck.Core (Flavor) +import Xrefcheck.Scan (ScanAction) import Xrefcheck.Scanners.Markdown (MarkdownConfig (MarkdownConfig, mcFlavor), markdownScanner) +import Xrefcheck.System (PrintUnixPaths (..)) -parse :: Flavor -> FilePath -> IO (FileInfo, [ScanError]) -parse fl path = markdownScanner MarkdownConfig { mcFlavor = fl } path +parse :: Flavor -> ScanAction +parse fl path = + give (PrintUnixPaths False) $ + markdownScanner MarkdownConfig { mcFlavor = fl } path -mockServer :: IO () -mockServer = run 3000 $ do - route "/401" $ pure $ toResponse ("" :: Text, unauthorized401) - route "/403" $ pure $ toResponse ("" :: Text, forbidden403) +mockServerUrl :: MockServerPort -> Text -> Text +mockServerUrl (MockServerPort port) s = toText ("http://127.0.0.1:" <> show port <> s) + +mockServer :: MockServerPort -> IO () +mockServer (MockServerPort port) = + Web.run port <=< Web.scottyApp $ do + Web.matchAny "/401" $ Web.status unauthorized401 + Web.matchAny "/403" $ Web.status forbidden403 + +-- | All options needed to configure the mock server. +mockServerOptions :: [OptionDescription] +mockServerOptions = + [ Tasty.Option (Proxy @MockServerPort) + ] + +-- | Option specifying FTP host. +newtype MockServerPort = MockServerPort Int + deriving stock (Show, Eq) + +instance IsOption MockServerPort where + defaultValue = MockServerPort 3000 + optionName = "mock-server-port" + optionHelp = "[Test.Xrefcheck.Util] Mock server port" + parseValue v = MockServerPort <$> safeRead v + optionCLParser = MockServerPort <$> option auto + ( long (untag @MockServerPort optionName) + <> help (untag @MockServerPort optionHelp) + ) diff --git a/tests/Test/Xrefcheck/UtilRequests.hs b/tests/Test/Xrefcheck/UtilRequests.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Xrefcheck/UtilRequests.hs @@ -0,0 +1,158 @@ +{- SPDX-FileCopyrightText: 2019 Serokell + - + - SPDX-License-Identifier: MPL-2.0 + -} + +module Test.Xrefcheck.UtilRequests + ( checkLinkAndProgressWithServer + , verifyLink + , verifyReferenceWithProgress + , checkMultipleLinksWithServer + , checkLinkAndProgressWithServerDefault + , verifyLinkDefault + , verifyReferenceWithProgressDefault + , withServer + , VerifyLinkTestEntry (..) + ) where + +import Universum hiding ((.~)) + +import Control.Concurrent (forkIO, killThread) +import Control.Exception qualified as E +import Control.Lens ((.~)) +import Data.Map qualified as M +import Data.Set qualified as S +import Network.Wai qualified as Web +import Network.Wai.Handler.Warp qualified as Web +import Test.Tasty.HUnit (assertBool) +import Text.Interpolation.Nyan + +import Xrefcheck.Config +import Xrefcheck.Core +import Xrefcheck.Progress +import Xrefcheck.Scan +import Xrefcheck.System +import Xrefcheck.Util +import Xrefcheck.Verify + +withServer :: (Int, IO Web.Application) -> IO () -> IO () +withServer (port, createApp) act = do + app <- createApp + ready :: MVar () <- newEmptyMVar + -- In the forked thread: the server puts () as soon as it's ready to process requests. + -- In the current therad: wait for () before running the action. + -- + -- This ensures that we don't encounter this error: + -- ConnectionFailure Network.Socket.connect: : does not exist (Connection refused) + E.bracket (serve ready app) killThread (\_ -> takeMVar ready >> act) + where + serve ready app = + forkIO $ Web.runSettings settings app + where + settings = + Web.setBeforeMainLoop (putMVar ready ()) $ + Web.setPort port Web.defaultSettings + +checkMultipleLinksWithServer + :: (Int, IO Web.Application) + -> IORef (S.Set DomainName) + -> [VerifyLinkTestEntry] + -> IO () +checkMultipleLinksWithServer mock setRef entries = + withServer mock $ do + forM_ entries $ \VerifyLinkTestEntry {..} -> + checkLinkAndProgress + vlteConfigModifier + setRef + vlteLink + vlteExpectedProgress + vlteExpectationErrors + +checkLinkAndProgressWithServer + :: (Config -> Config) + -> IORef (Set DomainName) + -> (Int, IO Web.Application) + -> Text + -> Progress Int Text + -> VerifyResult VerifyError + -> IO () +checkLinkAndProgressWithServer configModifier setRef mock link progress vrExpectation = + withServer mock $ + checkLinkAndProgress configModifier setRef link progress vrExpectation + +checkLinkAndProgress + :: (Config -> Config) + -> IORef (Set DomainName) + -> Text + -> Progress Int Text + -> VerifyResult VerifyError + -> IO () +checkLinkAndProgress configModifier setRef link progress vrExpectation = do + (result, progRes) <- verifyLink configModifier setRef link + flip assertBool (result == vrExpectation) + [int|| + Verification results differ: expected + #{interpolateIndentF 2 (show vrExpectation)} + but got + #{interpolateIndentF 2 (show result)} + |] + flip assertBool (progRes `sameProgress` progress) + [int|| + Expected the progress bar state to be + #{interpolateIndentF 2 (show progress)} + but got + #{interpolateIndentF 2 (show progRes)} + |] + +checkLinkAndProgressWithServerDefault + :: IORef (Set DomainName) + -> (Int, IO Web.Application) + -> Text + -> Progress Int Text + -> VerifyResult VerifyError + -> IO () +checkLinkAndProgressWithServerDefault = checkLinkAndProgressWithServer id + +verifyLink + :: (Config -> Config) + -> IORef (S.Set DomainName) + -> Text + -> IO (VerifyResult VerifyError, Progress Int Text) +verifyLink configModifier setRef link = do + let reference = Reference "" (Position "") $ RIExternal $ ELUrl link + progRef <- newIORef $ initVerifyProgress [reference] + result <- verifyReferenceWithProgress configModifier reference setRef progRef + progress <- readIORef progRef + return (result, vrExternal progress) + +verifyLinkDefault + :: IORef (Set DomainName) + -> Text + -> IO (VerifyResult VerifyError, Progress Int Text) +verifyLinkDefault = verifyLink id + +verifyReferenceWithProgress + :: (Config -> Config) + -> Reference + -> IORef (S.Set DomainName) + -> IORef VerifyProgress + -> IO (VerifyResult VerifyError) +verifyReferenceWithProgress configModifier reference setRef progRef = + fmap wrlItem <$> verifyReference + (defConfig GitHub & cExclusionsL . ecIgnoreExternalRefsToL .~ [] + & configModifier) + FullMode setRef progRef (RepoInfo M.empty mempty) (mkRelPosixLink "") reference + +verifyReferenceWithProgressDefault + :: Reference + -> IORef (Set DomainName) + -> IORef VerifyProgress + -> IO (VerifyResult VerifyError) +verifyReferenceWithProgressDefault = verifyReferenceWithProgress id + +data VerifyLinkTestEntry = VerifyLinkTestEntry + { vlteConfigModifier :: Config -> Config + , vlteLink :: Text + , vlteExpectedProgress :: Progress Int Text + , vlteExpectationErrors :: VerifyResult VerifyError + } diff --git a/xrefcheck.cabal b/xrefcheck.cabal --- a/xrefcheck.cabal +++ b/xrefcheck.cabal @@ -1,11 +1,11 @@ cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.35.0. +-- This file has been generated from package.yaml by hpack version 0.36.1. -- -- see: https://github.com/sol/hpack name: xrefcheck -version: 0.2.2 +version: 0.3.0 description: Please see the README on GitHub at homepage: https://github.com/serokell/xrefcheck#readme bug-reports: https://github.com/serokell/xrefcheck/issues @@ -30,14 +30,18 @@ Xrefcheck.Config Xrefcheck.Config.Default Xrefcheck.Core + Xrefcheck.Data.Redirect + Xrefcheck.Data.URI Xrefcheck.Orphans Xrefcheck.Progress Xrefcheck.Scan Xrefcheck.Scanners Xrefcheck.Scanners.Markdown + Xrefcheck.Scanners.Symlink Xrefcheck.System Xrefcheck.Util Xrefcheck.Util.Colorize + Xrefcheck.Util.Interpolate Xrefcheck.Verify other-modules: Paths_xrefcheck @@ -66,18 +70,19 @@ NamedFieldPuns NoImplicitPrelude OverloadedStrings + QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections + TypeApplications TypeFamilies + TypeOperators UndecidableInstances ViewPatterns - TypeApplications - TypeOperators - ghc-options: -Weverything -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wno-missing-safe-haskell-mode -Wno-unsafe -Wno-missing-import-lists -Wno-missing-local-signatures -Wno-missing-export-lists -Wno-all-missed-specialisations -Wno-prepositive-qualified-module -Wno-monomorphism-restriction + ghc-options: -Weverything -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wno-missing-safe-haskell-mode -Wno-unsafe -Wno-missing-import-lists -Wno-missing-local-signatures -Wno-missing-export-lists -Wno-all-missed-specialisations -Wno-prepositive-qualified-module -Wno-monomorphism-restriction -Wno-missing-kind-signatures -optP-Wno-nonportable-include-path build-depends: Glob , aeson @@ -87,10 +92,9 @@ , bytestring , cmark-gfm >=0.2.5 , containers - , data-default + , crypton-connection , directory , dlist - , exceptions , filepath , fmt , ftp-client @@ -99,18 +103,18 @@ , lens , modern-uri , mtl + , nyan-interpolation , o-clock , optparse-applicative , pretty-terminal , process - , raw-strings-qq , reflection , regex-tdfa , req + , safe-exceptions , tagsoup , text , text-metrics - , th-lift-instances , time , transformers , universum @@ -147,21 +151,23 @@ NamedFieldPuns NoImplicitPrelude OverloadedStrings + QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections + TypeApplications TypeFamilies + TypeOperators UndecidableInstances ViewPatterns - TypeApplications - TypeOperators - ghc-options: -Weverything -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wno-missing-safe-haskell-mode -Wno-unsafe -Wno-missing-import-lists -Wno-missing-local-signatures -Wno-missing-export-lists -Wno-all-missed-specialisations -Wno-prepositive-qualified-module -Wno-monomorphism-restriction -threaded -rtsopts -with-rtsopts=-N -O2 + ghc-options: -Weverything -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wno-missing-safe-haskell-mode -Wno-unsafe -Wno-missing-import-lists -Wno-missing-local-signatures -Wno-missing-export-lists -Wno-all-missed-specialisations -Wno-prepositive-qualified-module -Wno-monomorphism-restriction -Wno-missing-kind-signatures -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N -O2 build-depends: base >=4.14.3.0 && <5 - , bytestring + , code-page + , directory , universum , with-utf8 , xrefcheck @@ -199,22 +205,24 @@ NamedFieldPuns NoImplicitPrelude OverloadedStrings + QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections + TypeApplications TypeFamilies + TypeOperators UndecidableInstances ViewPatterns - TypeApplications - TypeOperators - ghc-options: -Weverything -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wno-missing-safe-haskell-mode -Wno-unsafe -Wno-missing-import-lists -Wno-missing-local-signatures -Wno-missing-export-lists -Wno-all-missed-specialisations -Wno-prepositive-qualified-module -Wno-monomorphism-restriction + ghc-options: -Weverything -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wno-missing-safe-haskell-mode -Wno-unsafe -Wno-missing-import-lists -Wno-missing-local-signatures -Wno-missing-export-lists -Wno-all-missed-specialisations -Wno-prepositive-qualified-module -Wno-monomorphism-restriction -Wno-missing-kind-signatures -optP-Wno-nonportable-include-path build-tool-depends: tasty-discover:tasty-discover build-depends: base >=4.14.3.0 && <5 + , lens , optparse-applicative , tagged , tasty @@ -229,14 +237,19 @@ other-modules: Test.Xrefcheck.AnchorsInHeadersSpec Test.Xrefcheck.AnchorsSpec + Test.Xrefcheck.CanonicalRelPosixLinkSpec Test.Xrefcheck.ConfigSpec Test.Xrefcheck.IgnoreAnnotationsSpec Test.Xrefcheck.IgnoreRegexSpec - Test.Xrefcheck.LocalSpec + Test.Xrefcheck.RedirectChainSpec + Test.Xrefcheck.RedirectConfigSpec + Test.Xrefcheck.RedirectDefaultSpec + Test.Xrefcheck.TimeoutSpec Test.Xrefcheck.TooManyRequestsSpec Test.Xrefcheck.TrailingSlashSpec Test.Xrefcheck.URIParsingSpec Test.Xrefcheck.Util + Test.Xrefcheck.UtilRequests Tree Paths_xrefcheck autogen-modules: @@ -264,40 +277,46 @@ NamedFieldPuns NoImplicitPrelude OverloadedStrings + QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections + TypeApplications TypeFamilies + TypeOperators UndecidableInstances ViewPatterns - TypeApplications - TypeOperators - ghc-options: -Weverything -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wno-missing-safe-haskell-mode -Wno-unsafe -Wno-missing-import-lists -Wno-missing-local-signatures -Wno-missing-export-lists -Wno-all-missed-specialisations -Wno-prepositive-qualified-module -Wno-monomorphism-restriction + ghc-options: -Weverything -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wno-missing-safe-haskell-mode -Wno-unsafe -Wno-missing-import-lists -Wno-missing-local-signatures -Wno-missing-export-lists -Wno-all-missed-specialisations -Wno-prepositive-qualified-module -Wno-monomorphism-restriction -Wno-missing-kind-signatures -optP-Wno-nonportable-include-path build-tool-depends: tasty-discover:tasty-discover build-depends: base >=4.14.3.0 && <5 - , bytestring , case-insensitive , cmark-gfm , containers , directory - , firefly - , fmt + , filepath , http-types + , lens , modern-uri + , nyan-interpolation , o-clock + , optparse-applicative , reflection , regex-tdfa + , scotty + , tagged , tasty , tasty-hunit , tasty-quickcheck , time , universum , uri-bytestring + , wai + , warp , xrefcheck , yaml default-language: Haskell2010