xrefcheck 0.2.2 → 0.3.0
raw patch · 38 files changed
+3509/−1559 lines, 38 filesdep +code-pagedep +crypton-connectiondep +nyan-interpolationdep −data-defaultdep −exceptionsdep −fireflydep ~optparse-applicativenew-uploader
Dependencies added: code-page, crypton-connection, nyan-interpolation, safe-exceptions, scotty, wai, warp
Dependencies removed: data-default, exceptions, firefly, raw-strings-qq, th-lift-instances
Dependency ranges changed: optparse-applicative
Files
- CHANGES.md +63/−6
- README.md +138/−116
- exec/Main.hs +11/−5
- ftp-tests/Test/Xrefcheck/FtpLinks.hs +23/−26
- src/Xrefcheck/CLI.hs +121/−72
- src/Xrefcheck/Command.hs +39/−33
- src/Xrefcheck/Config.hs +106/−201
- src/Xrefcheck/Config/Default.hs +129/−31
- src/Xrefcheck/Core.hs +184/−123
- src/Xrefcheck/Data/Redirect.hs +170/−0
- src/Xrefcheck/Data/URI.hs +74/−0
- src/Xrefcheck/Orphans.hs +7/−5
- src/Xrefcheck/Progress.hs +117/−72
- src/Xrefcheck/Scan.hs +233/−101
- src/Xrefcheck/Scanners/Markdown.hs +117/−93
- src/Xrefcheck/Scanners/Symlink.hs +39/−0
- src/Xrefcheck/System.hs +230/−55
- src/Xrefcheck/Util.hs +16/−7
- src/Xrefcheck/Util/Interpolate.hs +86/−0
- src/Xrefcheck/Verify.hs +539/−337
- tests/Main.hs +6/−1
- tests/Test/Xrefcheck/AnchorsInHeadersSpec.hs +5/−3
- tests/Test/Xrefcheck/AnchorsSpec.hs +5/−3
- tests/Test/Xrefcheck/CanonicalRelPosixLinkSpec.hs +49/−0
- tests/Test/Xrefcheck/ConfigSpec.hs +31/−32
- tests/Test/Xrefcheck/IgnoreAnnotationsSpec.hs +28/−23
- tests/Test/Xrefcheck/IgnoreRegexSpec.hs +18/−8
- tests/Test/Xrefcheck/LocalSpec.hs +0/−25
- tests/Test/Xrefcheck/RedirectChainSpec.hs +162/−0
- tests/Test/Xrefcheck/RedirectConfigSpec.hs +193/−0
- tests/Test/Xrefcheck/RedirectDefaultSpec.hs +86/−0
- tests/Test/Xrefcheck/TimeoutSpec.hs +146/−0
- tests/Test/Xrefcheck/TooManyRequestsSpec.hs +69/−125
- tests/Test/Xrefcheck/TrailingSlashSpec.hs +20/−14
- tests/Test/Xrefcheck/URIParsingSpec.hs +8/−10
- tests/Test/Xrefcheck/Util.hs +41/−9
- tests/Test/Xrefcheck/UtilRequests.hs +158/−0
- xrefcheck.cabal +42/−23
CHANGES.md view
@@ -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+ `<!-- xrefcheck: ignore all -->` instead of `<!-- xrefcheck: ignore file -->`+ 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 =======
README.md view
@@ -6,46 +6,46 @@ # Xrefcheck -[](https://buildkite.com/serokell/xrefcheck)++<img referrerpolicy="no-referrer-when-downgrade" src="https://static.scarf.sh/a.png?x-pxid=bdf72cff-c1f1-4b3a-97f0-5083dbb77fa6" /> -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. -<img src="https://user-images.githubusercontent.com/5394217/70820564-06b06e00-1dea-11ea-9680-27f661ca2a58.png" alt="Output sample" width="600"/>+<img src="./docs/output-sample/output-sample.png" alt="Output sample" width="600"/> -### 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--<details>- <summary>Ignoring external links</summary>-- 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) <!-- xrefcheck: ignore link --> 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 <!-- xrefcheck: ignore link -->- ['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- <!-- xrefcheck: ignore link -->- [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 -- <args>` instead of `xrefcheck.exe <args>`+- add DLLs from archive from releases page to a folder containing `xrefcheck.exe` - ```markdown- <!-- xrefcheck: ignore paragraph -->- 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 <glob pattern>` 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 `<!-- xrefcheck: ignore link -->` annotation before the link:+ ```md+ <!-- xrefcheck: ignore link -->+ Link to some [invalid resource](https://fictitious.uri/).+ ```+ ```md+ A [valid link](https://www.google.com)+ followed by an <!-- xrefcheck: ignore link --> [invalid link](https://fictitious.uri/).+ ```+ * You can also use a `<!-- xrefcheck: ignore paragraph -->` annotation to ignore all links in a paragraph. - * Ignore the whole file:- ```markdown- <!-- a comment -->- <!-- another comment -->+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 `<!-- xrefcheck: ignore all -->` at the top of the file. - <!-- xrefcheck: ignore 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.- </details>+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)
exec/Main.hs view
@@ -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)
ftp-tests/Test/Xrefcheck/FtpLinks.hs view
@@ -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) ]
src/Xrefcheck/CLI.hs view
@@ -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 \"<!-- xrefcheck: ignore <mode> -->\"\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
src/Xrefcheck/Command.hs view
@@ -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."
src/Xrefcheck/Config.hs view
@@ -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:<key>:@ 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
src/Xrefcheck/Config/Default.hs view
@@ -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|]
src/Xrefcheck/Core.hs view
@@ -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{..} =
+ src/Xrefcheck/Data/Redirect.hs view
@@ -0,0 +1,170 @@+{- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io>+ -+ - 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
+ src/Xrefcheck/Data/URI.hs view
@@ -0,0 +1,74 @@+{- SPDX-FileCopyrightText: 2023 Serokell <https://serokell.io>+ -+ - 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)
src/Xrefcheck/Orphans.hs view
@@ -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"
src/Xrefcheck/Progress.hs view
@@ -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
src/Xrefcheck/Scan.hs view
@@ -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
src/Xrefcheck/Scanners/Markdown.hs view
@@ -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
+ src/Xrefcheck/Scanners/Symlink.hs view
@@ -0,0 +1,39 @@+{- SPDX-FileCopyrightText: 2023 Serokell <https://serokell.io>+ -+ - 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
src/Xrefcheck/System.hs view
@@ -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> -> [<]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> -> [<]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
src/Xrefcheck/Util.hs view
@@ -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
+ src/Xrefcheck/Util/Interpolate.hs view
@@ -0,0 +1,86 @@+{- SPDX-FileCopyrightText: 2018-2019 Serokell <https://serokell.io>+ -+ - 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
src/Xrefcheck/Verify.hs view
@@ -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
tests/Main.hs view
@@ -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
tests/Test/Xrefcheck/AnchorsInHeadersSpec.hs view
@@ -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 @?= [] ]
tests/Test/Xrefcheck/AnchorsSpec.hs view
@@ -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"
+ tests/Test/Xrefcheck/CanonicalRelPosixLinkSpec.hs view
@@ -0,0 +1,49 @@+{- SPDX-FileCopyrightText: 2023 Serokell <https://serokell.io>+ -+ - 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
tests/Test/Xrefcheck/ConfigSpec.hs view
@@ -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
tests/Test/Xrefcheck/IgnoreAnnotationsSpec.hs view
@@ -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)
tests/Test/Xrefcheck/IgnoreRegexSpec.hs view
@@ -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
− tests/Test/Xrefcheck/LocalSpec.hs
@@ -1,25 +0,0 @@-{- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>- -- - 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"- ]
+ tests/Test/Xrefcheck/RedirectChainSpec.hs view
@@ -0,0 +1,162 @@+{- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io>+ -+ - 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
+ tests/Test/Xrefcheck/RedirectConfigSpec.hs view
@@ -0,0 +1,193 @@+{- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io>+ -+ - 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
+ tests/Test/Xrefcheck/RedirectDefaultSpec.hs view
@@ -0,0 +1,86 @@+{- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io>+ -+ - 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)
+ tests/Test/Xrefcheck/TimeoutSpec.hs view
@@ -0,0 +1,146 @@+{- SPDX-FileCopyrightText: 2021 Serokell <https://serokell.io>+ -+ - 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
tests/Test/Xrefcheck/TooManyRequestsSpec.hs view
@@ -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)
tests/Test/Xrefcheck/TrailingSlashSpec.hs view
@@ -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 =
tests/Test/Xrefcheck/URIParsingSpec.hs view
@@ -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://exa<mple.co>m/?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
tests/Test/Xrefcheck/Util.hs view
@@ -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)+ )
+ tests/Test/Xrefcheck/UtilRequests.hs view
@@ -0,0 +1,158 @@+{- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>+ -+ - 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: <socket: 4>: 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+ }
xrefcheck.cabal view
@@ -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 <https://github.com/serokell/xrefcheck#readme> 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