xrefcheck (empty) → 0.1.0.0
raw patch · 22 files changed
+2054/−0 lines, 22 filesdep +Globdep +QuickCheckdep +aesonsetup-changed
Dependencies added: Glob, QuickCheck, aeson, aeson-options, async, base-noprelude, bytestring, cmark-gfm, containers, data-default, deepseq, directory, directory-tree, filepath, fmt, hspec, http-client, http-types, lens, loot-prelude, mtl, o-clock, optparse-applicative, pretty-terminal, req, roman-numerals, template-haskell, text, text-metrics, th-lift-instances, th-utilities, xrefcheck, yaml
Files
- CHANGES.md +13/−0
- LICENSE +373/−0
- README.md +128/−0
- Setup.hs +7/−0
- exec/Main.hs +77/−0
- src-files/def-config.yaml +51/−0
- src/Xrefcheck/CLI.hs +122/−0
- src/Xrefcheck/Config.hs +70/−0
- src/Xrefcheck/Core.hs +280/−0
- src/Xrefcheck/Progress.hs +119/−0
- src/Xrefcheck/Scan.hs +80/−0
- src/Xrefcheck/Scanners.hs +6/−0
- src/Xrefcheck/Scanners/Markdown.hs +102/−0
- src/Xrefcheck/System.hs +29/−0
- src/Xrefcheck/Util.hs +26/−0
- src/Xrefcheck/Verify.hs +290/−0
- tests/Main.hs +10/−0
- tests/Spec.hs +6/−0
- tests/Test/Xrefcheck/AnchorsSpec.hs +50/−0
- tests/Test/Xrefcheck/ConfigSpec.hs +16/−0
- tests/Test/Xrefcheck/LocalSpec.hs +23/−0
- xrefcheck.cabal +176/−0
+ CHANGES.md view
@@ -0,0 +1,13 @@+<!--+ - SPDX-FileCopyrightText: 2020 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -->++Unreleased+==========++0.1.0.0+=======++Initial release.
+ LICENSE view
@@ -0,0 +1,373 @@+Mozilla Public License Version 2.0+==================================++1. Definitions+--------------++1.1. "Contributor"+ means each individual or legal entity that creates, contributes to+ the creation of, or owns Covered Software.++1.2. "Contributor Version"+ means the combination of the Contributions of others (if any) used+ by a Contributor and that particular Contributor's Contribution.++1.3. "Contribution"+ means Covered Software of a particular Contributor.++1.4. "Covered Software"+ means Source Code Form to which the initial Contributor has attached+ the notice in Exhibit A, the Executable Form of such Source Code+ Form, and Modifications of such Source Code Form, in each case+ including portions thereof.++1.5. "Incompatible With Secondary Licenses"+ means++ (a) that the initial Contributor has attached the notice described+ in Exhibit B to the Covered Software; or++ (b) that the Covered Software was made available under the terms of+ version 1.1 or earlier of the License, but not also under the+ terms of a Secondary License.++1.6. "Executable Form"+ means any form of the work other than Source Code Form.++1.7. "Larger Work"+ means a work that combines Covered Software with other material, in+ a separate file or files, that is not Covered Software.++1.8. "License"+ means this document.++1.9. "Licensable"+ means having the right to grant, to the maximum extent possible,+ whether at the time of the initial grant or subsequently, any and+ all of the rights conveyed by this License.++1.10. "Modifications"+ means any of the following:++ (a) any file in Source Code Form that results from an addition to,+ deletion from, or modification of the contents of Covered+ Software; or++ (b) any new file in Source Code Form that contains any Covered+ Software.++1.11. "Patent Claims" of a Contributor+ means any patent claim(s), including without limitation, method,+ process, and apparatus claims, in any patent Licensable by such+ Contributor that would be infringed, but for the grant of the+ License, by the making, using, selling, offering for sale, having+ made, import, or transfer of either its Contributions or its+ Contributor Version.++1.12. "Secondary License"+ means either the GNU General Public License, Version 2.0, the GNU+ Lesser General Public License, Version 2.1, the GNU Affero General+ Public License, Version 3.0, or any later versions of those+ licenses.++1.13. "Source Code Form"+ means the form of the work preferred for making modifications.++1.14. "You" (or "Your")+ means an individual or a legal entity exercising rights under this+ License. For legal entities, "You" includes any entity that+ controls, is controlled by, or is under common control with You. For+ purposes of this definition, "control" means (a) the power, direct+ or indirect, to cause the direction or management of such entity,+ whether by contract or otherwise, or (b) ownership of more than+ fifty percent (50%) of the outstanding shares or beneficial+ ownership of such entity.++2. License Grants and Conditions+--------------------------------++2.1. Grants++Each Contributor hereby grants You a world-wide, royalty-free,+non-exclusive license:++(a) under intellectual property rights (other than patent or trademark)+ Licensable by such Contributor to use, reproduce, make available,+ modify, display, perform, distribute, and otherwise exploit its+ Contributions, either on an unmodified basis, with Modifications, or+ as part of a Larger Work; and++(b) under Patent Claims of such Contributor to make, use, sell, offer+ for sale, have made, import, and otherwise transfer either its+ Contributions or its Contributor Version.++2.2. Effective Date++The licenses granted in Section 2.1 with respect to any Contribution+become effective for each Contribution on the date the Contributor first+distributes such Contribution.++2.3. Limitations on Grant Scope++The licenses granted in this Section 2 are the only rights granted under+this License. No additional rights or licenses will be implied from the+distribution or licensing of Covered Software under this License.+Notwithstanding Section 2.1(b) above, no patent license is granted by a+Contributor:++(a) for any code that a Contributor has removed from Covered Software;+ or++(b) for infringements caused by: (i) Your and any other third party's+ modifications of Covered Software, or (ii) the combination of its+ Contributions with other software (except as part of its Contributor+ Version); or++(c) under Patent Claims infringed by Covered Software in the absence of+ its Contributions.++This License does not grant any rights in the trademarks, service marks,+or logos of any Contributor (except as may be necessary to comply with+the notice requirements in Section 3.4).++2.4. Subsequent Licenses++No Contributor makes additional grants as a result of Your choice to+distribute the Covered Software under a subsequent version of this+License (see Section 10.2) or under the terms of a Secondary License (if+permitted under the terms of Section 3.3).++2.5. Representation++Each Contributor represents that the Contributor believes its+Contributions are its original creation(s) or it has sufficient rights+to grant the rights to its Contributions conveyed by this License.++2.6. Fair Use++This License is not intended to limit any rights You have under+applicable copyright doctrines of fair use, fair dealing, or other+equivalents.++2.7. Conditions++Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted+in Section 2.1.++3. Responsibilities+-------------------++3.1. Distribution of Source Form++All distribution of Covered Software in Source Code Form, including any+Modifications that You create or to which You contribute, must be under+the terms of this License. You must inform recipients that the Source+Code Form of the Covered Software is governed by the terms of this+License, and how they can obtain a copy of this License. You may not+attempt to alter or restrict the recipients' rights in the Source Code+Form.++3.2. Distribution of Executable Form++If You distribute Covered Software in Executable Form then:++(a) such Covered Software must also be made available in Source Code+ Form, as described in Section 3.1, and You must inform recipients of+ the Executable Form how they can obtain a copy of such Source Code+ Form by reasonable means in a timely manner, at a charge no more+ than the cost of distribution to the recipient; and++(b) You may distribute such Executable Form under the terms of this+ License, or sublicense it under different terms, provided that the+ license for the Executable Form does not attempt to limit or alter+ the recipients' rights in the Source Code Form under this License.++3.3. Distribution of a Larger Work++You may create and distribute a Larger Work under terms of Your choice,+provided that You also comply with the requirements of this License for+the Covered Software. If the Larger Work is a combination of Covered+Software with a work governed by one or more Secondary Licenses, and the+Covered Software is not Incompatible With Secondary Licenses, this+License permits You to additionally distribute such Covered Software+under the terms of such Secondary License(s), so that the recipient of+the Larger Work may, at their option, further distribute the Covered+Software under the terms of either this License or such Secondary+License(s).++3.4. Notices++You may not remove or alter the substance of any license notices+(including copyright notices, patent notices, disclaimers of warranty,+or limitations of liability) contained within the Source Code Form of+the Covered Software, except that You may alter any license notices to+the extent required to remedy known factual inaccuracies.++3.5. Application of Additional Terms++You may choose to offer, and to charge a fee for, warranty, support,+indemnity or liability obligations to one or more recipients of Covered+Software. However, You may do so only on Your own behalf, and not on+behalf of any Contributor. You must make it absolutely clear that any+such warranty, support, indemnity, or liability obligation is offered by+You alone, and You hereby agree to indemnify every Contributor for any+liability incurred by such Contributor as a result of warranty, support,+indemnity or liability terms You offer. You may include additional+disclaimers of warranty and limitations of liability specific to any+jurisdiction.++4. Inability to Comply Due to Statute or Regulation+---------------------------------------------------++If it is impossible for You to comply with any of the terms of this+License with respect to some or all of the Covered Software due to+statute, judicial order, or regulation then You must: (a) comply with+the terms of this License to the maximum extent possible; and (b)+describe the limitations and the code they affect. Such description must+be placed in a text file included with all distributions of the Covered+Software under this License. Except to the extent prohibited by statute+or regulation, such description must be sufficiently detailed for a+recipient of ordinary skill to be able to understand it.++5. Termination+--------------++5.1. The rights granted under this License will terminate automatically+if You fail to comply with any of its terms. However, if You become+compliant, then the rights granted under this License from a particular+Contributor are reinstated (a) provisionally, unless and until such+Contributor explicitly and finally terminates Your grants, and (b) on an+ongoing basis, if such Contributor fails to notify You of the+non-compliance by some reasonable means prior to 60 days after You have+come back into compliance. Moreover, Your grants from a particular+Contributor are reinstated on an ongoing basis if such Contributor+notifies You of the non-compliance by some reasonable means, this is the+first time You have received notice of non-compliance with this License+from such Contributor, and You become compliant prior to 30 days after+Your receipt of the notice.++5.2. If You initiate litigation against any entity by asserting a patent+infringement claim (excluding declaratory judgment actions,+counter-claims, and cross-claims) alleging that a Contributor Version+directly or indirectly infringes any patent, then the rights granted to+You by any and all Contributors for the Covered Software under Section+2.1 of this License shall terminate.++5.3. In the event of termination under Sections 5.1 or 5.2 above, all+end user license agreements (excluding distributors and resellers) which+have been validly granted by You or Your distributors under this License+prior to termination shall survive termination.++************************************************************************+* *+* 6. Disclaimer of Warranty *+* ------------------------- *+* *+* Covered Software is provided under this License on an "as is" *+* basis, without warranty of any kind, either expressed, implied, or *+* statutory, including, without limitation, warranties that the *+* Covered Software is free of defects, merchantable, fit for a *+* particular purpose or non-infringing. The entire risk as to the *+* quality and performance of the Covered Software is with You. *+* Should any Covered Software prove defective in any respect, You *+* (not any Contributor) assume the cost of any necessary servicing, *+* repair, or correction. This disclaimer of warranty constitutes an *+* essential part of this License. No use of any Covered Software is *+* authorized under this License except under this disclaimer. *+* *+************************************************************************++************************************************************************+* *+* 7. Limitation of Liability *+* -------------------------- *+* *+* Under no circumstances and under no legal theory, whether tort *+* (including negligence), contract, or otherwise, shall any *+* Contributor, or anyone who distributes Covered Software as *+* permitted above, be liable to You for any direct, indirect, *+* special, incidental, or consequential damages of any character *+* including, without limitation, damages for lost profits, loss of *+* goodwill, work stoppage, computer failure or malfunction, or any *+* and all other commercial damages or losses, even if such party *+* shall have been informed of the possibility of such damages. This *+* limitation of liability shall not apply to liability for death or *+* personal injury resulting from such party's negligence to the *+* extent applicable law prohibits such limitation. Some *+* jurisdictions do not allow the exclusion or limitation of *+* incidental or consequential damages, so this exclusion and *+* limitation may not apply to You. *+* *+************************************************************************++8. Litigation+-------------++Any litigation relating to this License may be brought only in the+courts of a jurisdiction where the defendant maintains its principal+place of business and such litigation shall be governed by laws of that+jurisdiction, without reference to its conflict-of-law provisions.+Nothing in this Section shall prevent a party's ability to bring+cross-claims or counter-claims.++9. Miscellaneous+----------------++This License represents the complete agreement concerning the subject+matter hereof. If any provision of this License is held to be+unenforceable, such provision shall be reformed only to the extent+necessary to make it enforceable. Any law or regulation which provides+that the language of a contract shall be construed against the drafter+shall not be used to construe this License against a Contributor.++10. Versions of the License+---------------------------++10.1. New Versions++Mozilla Foundation is the license steward. Except as provided in Section+10.3, no one other than the license steward has the right to modify or+publish new versions of this License. Each version will be given a+distinguishing version number.++10.2. Effect of New Versions++You may distribute the Covered Software under the terms of the version+of the License under which You originally received the Covered Software,+or under the terms of any subsequent version published by the license+steward.++10.3. Modified Versions++If you create software not governed by this License, and you want to+create a new license for such software, you may create and use a+modified version of this License if you rename the license and remove+any references to the name of the license steward (except to note that+such modified license differs from this License).++10.4. Distributing Source Code Form that is Incompatible With Secondary+Licenses++If You choose to distribute Source Code Form that is Incompatible With+Secondary Licenses under the terms of this version of the License, the+notice described in Exhibit B of this License must be attached.++Exhibit A - Source Code Form License Notice+-------------------------------------------++ This Source Code Form is subject to the terms of the Mozilla Public+ License, v. 2.0. If a copy of the MPL was not distributed with this+ file, You can obtain one at http://mozilla.org/MPL/2.0/.++If it is not possible or desirable to put the notice in a particular+file, then You may include the notice in a location (such as a LICENSE+file in a relevant directory) where a recipient would be likely to look+for such a notice.++You may add additional accurate notices of copyright ownership.++Exhibit B - "Incompatible With Secondary Licenses" Notice+---------------------------------------------------------++ This Source Code Form is "Incompatible With Secondary Licenses", as+ defined by the Mozilla Public License, v. 2.0.
+ README.md view
@@ -0,0 +1,128 @@+<!--+ - SPDX-FileCopyrightText: 2018-2019 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -->++# Xrefcheck++[](https://buildkite.com/serokell/xrefcheck)++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.++<img src="https://user-images.githubusercontent.com/5394217/70820564-06b06e00-1dea-11ea-9680-27f661ca2a58.png" alt="Output sample" width="600"/>++### Motivation++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.++This tool will help you to keep references in order.++### Aims++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.+* 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 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 writting, 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 file at a time.+ Supports `mailto:` link resolution.+* [url-checker](https://github.com/paramt/url-checker) - GitHub action which checks links in specified files.+* [broken-link-checker](https://github.com/stevenvachon/broken-link-checker) - advanced checker for `HTML` files.++## Build instructions [↑](#xrefcheck)++Run `stack install` to build everything and install the executable.++### CI and nix [↑](#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+```++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.++<details>+ <summary>Details</summary>++There is a [bug](https://github.com/input-output-hk/haskell.nix/issues/335) which causes us to put some redundancy into Nix files:+1. [`nix/sources.json`](nix/sources.json) lists all such dependencies that we obtain using `git`.+It specifies concrete git revisions and SHA256 checksums.+2. [`xrefcheck.nix`](xrefcheck.nix) lists all such dependencies as well, but without revisions.++As a consequence, you may have to update these files when you update [`stack.yaml`](stack.yaml).+You can use [`niv update`](https://github.com/nmattia/niv#update) to update [`nix/sources.json`](nix/sources.json).++</details>++## Usage [↑](#xrefcheck)++To find all broken links in a repository, run from within its folder:++```sh+xrefcheck+```++To also display all found links and anchors:++```sh+xrefcheck -v+```++For description of other options:++```sh+xrefcheck --help+```++## Configuring++Configuration template (with all options explained) can be dumped with:++```sh+xrefcheck dump-config+```++Currently supported options include:+* Timeout for checking external references;+* List of ignored folders.++## For further work [↑](#xrefcheck)++- [ ] Support for non-Unix systems.+- [ ] Support link detection in different languages, not only Markdown.+ - [ ] Haskell Haddock is first in turn.++## Issue tracker [↑](#xrefcheck)++We use GitHub issues as our issue tracker.+You can login using your GitHub account to leave a comment or create a new issue.++## For Contributors [↑](#xrefcheck)++Please see [CONTRIBUTING.md](/.github/CONTRIBUTING.md) for more information.++## About Serokell [↑](#xrefcheck)++Xrefcheck is maintained and funded with ❤️ by [Serokell](https://serokell.io/).+The names and logo for Serokell are trademark of Serokell OÜ.++We love open source software! See [our other projects](https://serokell.io/community?utm_source=github) or [hire us](https://serokell.io/hire-us?utm_source=github) to design, develop and grow your idea!
+ Setup.hs view
@@ -0,0 +1,7 @@+{- SPDX-FileCopyrightText: 2018-2019 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++import Distribution.Simple+main = defaultMain
+ exec/Main.hs view
@@ -0,0 +1,77 @@+{- SPDX-FileCopyrightText: 2018-2019 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++module Main where++import qualified Data.ByteString as BS+import Data.Yaml (decodeFileEither, prettyPrintParseException)+import Fmt (blockListF', build, fmt, fmtLn, indentF)+import System.Directory (doesFileExist)++import Xrefcheck.CLI+import Xrefcheck.Config+import Xrefcheck.Progress+import Xrefcheck.Scan+import Xrefcheck.Scanners+import Xrefcheck.Verify++formats :: FormatsSupport+formats = specificFormatsSupport+ [ markdownSupport+ ]++defaultAction :: Options -> IO ()+defaultAction Options{..} = do+ let root = oRoot++ config <- case oConfigPath of+ Nothing -> do+ mConfigPath <- findFirstExistingFile defaultConfigPaths+ case mConfigPath of+ Nothing -> do+ hPutStrLn @Text stderr "Configuration file not found, using default config\n"+ pure defConfig+ Just configPath ->+ readConfig configPath+ Just configPath -> do+ readConfig configPath++ repoInfo <- allowRewrite oShowProgressBar $ \rw ->+ gatherRepoInfo rw formats (cTraversal config) root++ when oVerbose $+ fmtLn $ "Repository data:\n\n" <> indentF 2 (build repoInfo)++ verifyRes <- allowRewrite oShowProgressBar $ \rw ->+ verifyRepo rw (cVerification config) oMode root repoInfo+ case verifyErrors verifyRes of+ Nothing ->+ fmtLn "All repository links are valid."+ Just (toList -> errs) -> do+ fmt $ "Invalid references found:\n\n" <>+ indentF 2 (blockListF' "➥ " build errs)+ fmtLn $ "Invalid references dumped, " <> build (length errs) <> " in total."+ exitFailure+ where+ findFirstExistingFile :: [FilePath] -> IO (Maybe FilePath)+ findFirstExistingFile = \case+ [] -> pure Nothing+ (file : files) -> do+ exists <- doesFileExist file+ if exists then pure (Just file) else findFirstExistingFile files++ readConfig :: FilePath -> IO Config+ readConfig path =+ decodeFileEither path+ >>= either (error . toText . prettyPrintParseException) pure++main :: IO ()+main = do+ command <- getCommand+ case command of+ DefaultCommand options ->+ defaultAction options+ DumpConfig path ->+ BS.writeFile path defConfigText
+ src-files/def-config.yaml view
@@ -0,0 +1,51 @@+# SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>+#+# SPDX-License-Identifier: Unlicense++# Parameters of repository traversal.+traversal:+ # Folders which we pretend do not exist+ # (so they are neither analyzed nor can be referenced).+ ignored:+ # Git files+ - .git++ # Stack files+ - .stack-work++# 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++ # When checking external references, how long to wait on request before+ # declaring "Response timeout".+ externalRefCheckTimeout: 10s++ # File prefixes, references in which should not be analyzed.+ notScanned:+ # GitHub-specific files+ - .github/pull_request_template.md+ - .github/issue_template.md+ - .github/PULL_REQUEST_TEMPLATE+ - .github/ISSUE_TEMPLATE++ # GitLab-specific files+ - .gitlab/merge_request_templates/+ - .gitlab/issue_templates/++ # Glob patterns describing the files which do not physically exist in the+ # repository but should be treated as existing nevertheless.+ virtualFiles:+ # GitHub pages+ - ../../../issues+ - ../../../issues/*+ - ../../../pulls+ - ../../../pulls/*++ # GitLab pages+ - ../../issues+ - ../../issues/*+ - ../../merge_requests+ - ../../merge_requests/*
+ src/Xrefcheck/CLI.hs view
@@ -0,0 +1,122 @@+{- SPDX-FileCopyrightText: 2018-2019 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++{-# LANGUAGE ApplicativeDo #-}++module Xrefcheck.CLI+ ( VerifyMode (..)+ , shouldCheckLocal+ , shouldCheckExternal+ , Command (..)+ , Options (..)+ , defaultConfigPaths+ , getCommand+ ) where++import Data.Version (showVersion)+import Options.Applicative (Parser, ReadM, command, eitherReader, execParser, fullDesc, help,+ helper, hsubparser, info, infoOption, long, metavar, option, progDesc,+ short, strOption, switch, value)+import Paths_xrefcheck (version)++import Xrefcheck.Core++modeReadM :: ReadM VerifyMode+modeReadM = eitherReader $ \s ->+ case find ((== s) . fst) modes of+ Just (_, mode) -> Right mode+ Nothing -> Left . mconcat $ intersperse "\n"+ [ "Unknown mode " <> show s <> "."+ , "Allowed values: " <> mconcat (intersperse ", " $ map (show . fst) modes)+ ]+ where+ modes =+ [ ("local-only", LocalOnlyMode)+ , ("external-only", ExternalOnlyMode)+ , ("full", FullMode)+ ]++data Command+ = DefaultCommand Options+ | DumpConfig FilePath++data Options = Options+ { oConfigPath :: Maybe FilePath+ , oRoot :: FilePath+ , oMode :: VerifyMode+ , oVerbose :: Bool+ , oShowProgressBar :: Bool+ }++-- | Where to try to seek configuration if specific path is not set.+defaultConfigPaths :: [FilePath]+defaultConfigPaths = ["./xrefcheck.yaml", "./.xrefcheck.yaml"]++optionsParser :: Parser Options+optionsParser = do+ oConfigPath <- optional . strOption $+ 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."+ )+ oRoot <- strOption $+ short 'r' <>+ long "root" <>+ metavar "DIRECTORY" <>+ help "Path to repository root." <>+ value "."+ oMode <- option modeReadM $+ short 'm' <>+ long "mode" <>+ metavar "KEYWORD" <>+ value FullMode <>+ help "Which parts of verification to invoke. \+ \You can enable only verification of repository-local references, \+ \only verification of external references or both. \+ \Default mode: full."+ oVerbose <- switch $+ short 'v' <>+ long "verbose" <>+ help "Report repository scan and verification details."+ oShowProgressBar <- fmap not . switch $+ long "no-progress" <>+ help "Do not display progress bar during verification."+ return Options{..}++dumpConfigOptions :: Parser FilePath+dumpConfigOptions = hsubparser $+ command "dump-config" $+ info parser $+ progDesc "Dump default configuration into a file."+ where+ parser = strOption $+ short 'o' <>+ long "output" <>+ metavar "FILEPATH" <>+ value ".xrefcheck.yaml" <>+ help "Name of created config file."++totalParser :: Parser Command+totalParser = asum+ [ DefaultCommand <$> optionsParser+ , DumpConfig <$> dumpConfigOptions+ ]++versionOption :: Parser (a -> a)+versionOption = infoOption ("xrefcheck-" <> showVersion version) $+ long "version" <>+ help "Show version."++getCommand :: IO Command+getCommand = do+ execParser $+ info (helper <*> versionOption <*> totalParser) $+ fullDesc <>+ progDesc "Cross-references verifier for markdown documentation in \+ \Git repositories."
+ src/Xrefcheck/Config.hs view
@@ -0,0 +1,70 @@+{- SPDX-FileCopyrightText: 2018-2019 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Xrefcheck.Config where++import Data.Aeson.Options (defaultOptions)+import Data.Aeson.TH (deriveFromJSON)+import Data.Yaml (FromJSON (..), decodeEither', prettyPrintParseException, withText)+import Instances.TH.Lift ()+import qualified Language.Haskell.TH.Syntax as TH+import System.FilePath.Posix ((</>))+import TH.RelativePaths (qReadFileBS)+import Time (KnownRatName, Second, Time, unitsP)++import Xrefcheck.System (CanonicalizedGlobPattern)++-- | Overall config.+data Config = Config+ { cTraversal :: TraversalConfig+ , cVerification :: VerifyConfig+ }++-- | Config of repositry traversal.+data TraversalConfig = TraversalConfig+ { tcIgnored :: [FilePath]+ -- ^ Folders, files in which we completely ignore.+ }++-- | Config of verification.+data VerifyConfig = VerifyConfig+ { vcAnchorSimilarityThreshold :: Double+ , vcExternalRefCheckTimeout :: Time Second+ , vcVirtualFiles :: [CanonicalizedGlobPattern]+ -- ^ Files which we pretend do exist.+ , vcNotScanned :: [FilePath]+ -- ^ Folders, references in files of which we should not analyze.+ }++-----------------------------------------------------------+-- Default config+-----------------------------------------------------------++-- | Default config in textual representation.+--+-- Sometimes you cannot just use 'defConfig' because clarifying comments+-- would be lost.+defConfigText :: ByteString+defConfigText =+ $(TH.lift =<< qReadFileBS ("src-files" </> "def-config.yaml"))++defConfig :: HasCallStack => Config+defConfig =+ either (error . toText . prettyPrintParseException) id $+ decodeEither' defConfigText++-----------------------------------------------------------+-- Yaml instances+-----------------------------------------------------------++deriveFromJSON defaultOptions ''Config+deriveFromJSON defaultOptions ''TraversalConfig+deriveFromJSON defaultOptions ''VerifyConfig++instance KnownRatName unit => FromJSON (Time unit) where+ parseJSON = withText "time" $+ maybe (fail "Unknown time") pure . unitsP . toString
+ src/Xrefcheck/Core.hs view
@@ -0,0 +1,280 @@+{- SPDX-FileCopyrightText: 2018-2019 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++{-# LANGUAGE PatternSynonyms #-}++-- | Various primitives.++module Xrefcheck.Core where++import Control.DeepSeq (NFData)+import Control.Lens (makeLenses, (%=))+import Data.Char (isAlphaNum)+import qualified Data.Char as C+import Data.Default (Default (..))+import qualified Data.List as L+import qualified Data.Map as M+import qualified Data.Text as T+import Fmt (Buildable (..), blockListF, blockListF', nameF, (+|), (|+))+import System.Console.Pretty (Color (..), Style (..), color, style)+import System.FilePath.Posix (isPathSeparator, pathSeparator)+import Text.Numeral.Roman (toRoman)++import Xrefcheck.Progress+import Xrefcheck.Util++-----------------------------------------------------------+-- Types+-----------------------------------------------------------++-- | 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)+ deriving (Show, Generic)++instance Buildable Position where+ build (Position pos) = case pos of+ Nothing -> ""+ Just p -> style Faint $ "at src:" <> build p++-- | Full info about a reference.+data Reference = Reference+ { rName :: Text+ -- ^ Text displayed as reference.+ , rLink :: Text+ -- ^ File or site reference points to.+ , rAnchor :: Maybe Text+ -- ^ Section or custom anchor tag.+ , rPos :: Position+ } deriving (Show, Generic)++-- | Context of anchor.+data AnchorType+ = HeaderAnchor Int+ -- ^ Every section header is usually an anchor+ | HandAnchor+ -- ^ They can be set up manually+ | BiblioAnchor+ -- ^ Id of entry in bibliography+ deriving (Show, Eq, Generic)++-- | A referable anchor.+data Anchor = Anchor+ { aType :: AnchorType+ , aName :: Text+ , aPos :: Position+ } deriving (Show, Generic)++-- | All information regarding a single file we care about.+data FileInfo = FileInfo+ { _fiReferences :: [Reference]+ , _fiAnchors :: [Anchor]+ } deriving (Show, Generic)+makeLenses ''FileInfo++instance Default FileInfo where+ def = FileInfo [] []++newtype RepoInfo = RepoInfo (Map FilePath FileInfo)+ deriving (Show)++finaliseFileInfo :: FileInfo -> FileInfo+finaliseFileInfo = execState $ do+ fiReferences %= reverse+ fiAnchors %= reverse++-----------------------------------------------------------+-- Instances+-----------------------------------------------------------++instance NFData Position+instance NFData Reference+instance NFData AnchorType+instance NFData Anchor+instance NFData FileInfo++instance Buildable Reference where+ build Reference{..} =+ nameF ("reference " +| paren (build loc) |+ " " +| rPos |+ "") $+ blockListF+ [ "text: " <> show rName+ , "link: " <> build rLink+ , "anchor: " <> build (rAnchor ?: style Faint "-")+ ]+ where+ loc = locationType rLink++instance Buildable AnchorType where+ build = style Faint . \case+ HeaderAnchor l -> color Green ("header " <> toRoman l)+ HandAnchor -> color Yellow "hand made"+ BiblioAnchor -> color Cyan "biblio"++instance Buildable Anchor where+ build (Anchor t a p) = a |+ " (" +| t |+ ") " +| p |+ ""++instance Buildable FileInfo where+ build FileInfo{..} =+ blockListF+ [ nameF "references" $ blockListF _fiReferences+ , nameF "anchors" $ blockListF _fiAnchors+ ]++instance Buildable RepoInfo where+ build (RepoInfo m) =+ blockListF' "⮚" buildFileReport (M.toList m)+ where+ buildFileReport (name, info) = mconcat+ [ color Cyan $ fromString name <> ":\n"+ , build info+ , "\n"+ ]++-----------------------------------------------------------+-- Analysing+-----------------------------------------------------------++pattern PathSep :: Char+pattern PathSep <- (isPathSeparator -> True)++-- | Type of reference.+data LocationType+ = LocalLoc+ -- ^ Reference on this file+ | RelativeLoc+ -- ^ Reference to a file relative to given one+ | AbsoluteLoc+ -- ^ Reference to a file relative to the root+ | ExternalLoc+ -- ^ Reference to a file at outer site+ | OtherLoc+ -- ^ Entry not to be processed (e.g. "mailto:e-mail")+ deriving (Show)++instance Buildable LocationType where+ build = \case+ LocalLoc -> color Green "local"+ RelativeLoc -> color Yellow "relative"+ AbsoluteLoc -> color Blue "absolute"+ ExternalLoc -> color 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+ LocalLoc -> True+ RelativeLoc -> True+ AbsoluteLoc -> True+ ExternalLoc -> False+ OtherLoc -> False++-- | Get type of reference.+locationType :: Text -> LocationType+locationType location = case toString location of+ [] -> LocalLoc+ 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+ | ExternalOnlyMode+ | FullMode++shouldCheckLocal :: VerifyMode -> Bool+shouldCheckLocal = \case+ LocalOnlyMode -> True+ ExternalOnlyMode -> False+ FullMode -> True++shouldCheckExternal :: VerifyMode -> Bool+shouldCheckExternal = \case+ LocalOnlyMode -> False+ ExternalOnlyMode -> True+ FullMode -> True++-- | Convert section header name to an anchor refering it.+-- Conversion rules: https://docs.gitlab.com/ee/user/markdown.html#header-ids-and-links+headerToAnchor :: Text -> Text+headerToAnchor t = t+ & T.toLower+ & T.replace "+" tmp+ & T.replace " " tmp+ & joinSyms tmp+ & T.replace (tmp <> "-") "-"+ & T.replace ("-" <> tmp) "-"+ & T.replace tmp "-"+ & T.filter (\c -> isAlphaNum c || c == '_' || c == '-')+ where+ joinSyms sym = T.intercalate sym . filter (not . null) . T.splitOn sym+ tmp = "\0"++-- | When there are several anchors with the same name, github automatically attaches+-- "-<number>" suffixes to duplications to make them referable unambiguously.+-- For instance, if there are two headers called "description", they would gain+-- "description" and "description-1" anchors correspondingly.+--+-- This function strips this suffix and returns the original anchor in case when+-- suffix is present.+stripAnchorDupNo :: Text -> Maybe Text+stripAnchorDupNo t = do+ let strippedNo = T.dropWhileEnd C.isNumber t+ guard (length strippedNo < length t)+ T.stripSuffix "-" strippedNo++-- | Strip './' prefix from local references.+canonizeLocalRef :: Text -> Text+canonizeLocalRef ref =+ case T.stripPrefix localPrefix ref of+ Nothing -> ref+ Just r -> canonizeLocalRef r+ where+ localPrefix = toText ['.', pathSeparator]++-----------------------------------------------------------+-- Visualisation+-----------------------------------------------------------++data VerifyProgress = VerifyProgress+ { vrLocal :: !(Progress Int)+ , vrExternal :: !(Progress Int)+ } deriving (Show)++initVerifyProgress :: [Reference] -> VerifyProgress+initVerifyProgress references =+ VerifyProgress+ { vrLocal = initProgress (length localRefs)+ , vrExternal = initProgress (length extRefs)+ }+ where+ (extRefs, localRefs) =+ L.partition isExternal $+ map (locationType . rLink) references++showAnalyseProgress :: VerifyMode -> VerifyProgress -> Text+showAnalyseProgress mode VerifyProgress{..} = mconcat . mconcat $+ [ [ "Verifying " ]+ , [ showProgress "local" 10 White vrLocal <> " "+ | shouldCheckLocal mode ]+ , [ showProgress "external" 15 Yellow vrExternal+ | shouldCheckExternal mode ]+ ]++reprintAnalyseProgress :: Rewrite -> VerifyMode -> VerifyProgress -> IO ()+reprintAnalyseProgress rw mode p = putTextRewrite rw (showAnalyseProgress mode p)
+ src/Xrefcheck/Progress.hs view
@@ -0,0 +1,119 @@+{- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++-- | Printing progress bars.+module Xrefcheck.Progress+ ( -- * Progress+ Progress (..)+ , initProgress+ , incProgress+ , incProgressErrors+ , showProgress++ -- * Printing+ , Rewrite+ , allowRewrite+ , putTextRewrite+ ) where++import Data.Ratio ((%))+import System.Console.Pretty (Color (..), Style (..), color, style)+import Time (ms, threadDelay)++-----------------------------------------------------------+-- Progress+-----------------------------------------------------------++-- | Processing progress of any thing.+data Progress a = Progress+ { pCurrent :: a+ -- ^ How much has been completed.+ , pTotal :: a+ -- ^ Overall amount of work.+ , pErrors :: !a+ -- ^ How many of the completed work finished with an error.+ } deriving (Show)++-- | Initialise null progress.+initProgress :: Num a => a -> Progress a+initProgress a = Progress{ pTotal = a, pCurrent = 0, pErrors = 0 }++-- | Increase progress amount.+incProgress :: (Num a, Show a) => Progress a -> Progress a+incProgress Progress{..} = Progress{ pCurrent = pCurrent + 1, .. }++-- | Increase errors amount.+incProgressErrors :: (Num a, Show a) => Progress a -> Progress a+incProgressErrors Progress{..} = Progress{ pErrors = pErrors + 1, .. }++-- | Visualise progress bar.+showProgress :: Text -> Int -> Color -> Progress Int -> Text+showProgress name width col Progress{..} = mconcat+ [ color col (name <> ": [")+ , toText bar+ , color col "]"+ , status+ ]+ where+ done = floor $ (pCurrent % pTotal) * fromIntegral width+ errs = ceiling $ (pErrors % pTotal) * fromIntegral width+ done' = max 0 $ done - errs+ remained' = width - errs - done'+ bar | pTotal == 0 = replicate width '-'+ | otherwise = mconcat+ [ color Red $ replicate errs '■'+ , color col $ replicate done' '■'+ , color col $ replicate remained' ' '+ , " "+ ]+ status+ | pTotal == 0 = ""+ | pErrors == 0 = style Faint $ color White "✓"+ | otherwise = color Red "!"++-----------------------------------------------------------+-- Rewritable output+-----------------------------------------------------------++-- | Rewrites state.+data RewriteCtx = RewriteCtx+ { rMaxPrintedSize :: IORef Int+ }++-- | Passing this object allows returning caret and replace text in line.+-- Only functions which has this thing can do that because being+-- interleaved with 'putTextLn' printing caret symbol produced garbage.+data Rewrite+ = Rewrite RewriteCtx+ -- ^ Default value.+ | RewriteDisabled+ -- ^ Do not print anything which will be rewritten.+ -- Useful when terminal does not interpret caret returns as expected.++-- | Provide context for rewrite operations.+allowRewrite :: (MonadIO m, MonadMask m) => Bool -> (Rewrite -> m a) -> m a+allowRewrite enabled action =+ bracket prepare erase action+ where+ prepare+ | enabled = do+ rMaxPrintedSize <- newIORef 0+ return $ Rewrite RewriteCtx{..}+ | otherwise =+ pure RewriteDisabled+ erase (Rewrite RewriteCtx{..}) = liftIO $ do+ maxPrintedSize <- readIORef rMaxPrintedSize+ hPutStr stderr $ '\r' : replicate maxPrintedSize ' ' ++ "\r"+ -- prevent our output to interleave with further outputs+ threadDelay (ms 100)+ erase RewriteDisabled = pass++-- | Return caret and print the given text.+putTextRewrite :: MonadIO m => Rewrite -> Text -> m ()+putTextRewrite (Rewrite RewriteCtx{..}) msg = do+ liftIO $ hPutStr stderr ('\r' : toString msg)+ atomicModifyIORef' rMaxPrintedSize $ \maxPrinted ->+ (max maxPrinted (length msg), ())+putTextRewrite RewriteDisabled _ = pass
+ src/Xrefcheck/Scan.hs view
@@ -0,0 +1,80 @@+{- SPDX-FileCopyrightText: 2018-2019 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++-- | Generalised repo scanner and analyser.++module Xrefcheck.Scan+ ( Extension+ , ScanAction+ , FormatsSupport+ , RepoInfo (..)++ , gatherRepoInfo+ , specificFormatsSupport+ ) where++import qualified Data.Foldable as F+import qualified Data.Map as M+import GHC.Err (errorWithoutStackTrace)+import qualified System.Directory.Tree as Tree+import System.FilePath.Posix (takeDirectory, takeExtension, (</>))++import Xrefcheck.Config+import Xrefcheck.Core+import Xrefcheck.Progress+import Xrefcheck.Util ()++-- | File extension, dot included.+type Extension = String++-- | Way to parse a file.+type ScanAction = FilePath -> IO FileInfo++-- | All supported ways to parse a file.+type FormatsSupport = Extension -> Maybe ScanAction++specificFormatsSupport :: [([Extension], ScanAction)] -> FormatsSupport+specificFormatsSupport formats = \ext -> M.lookup ext formatsMap+ where+ formatsMap = M.fromList+ [ (extension, parser)+ | (extensions, parser) <- formats+ , extension <- extensions+ ]++gatherRepoInfo+ :: MonadIO m+ => Rewrite -> FormatsSupport -> TraversalConfig -> FilePath -> m RepoInfo+gatherRepoInfo rw formatsSupport config root = do+ putTextRewrite rw "Scanning repository..."+ _ Tree.:/ repoTree <- liftIO $ Tree.readDirectoryWithL processFile rootNE+ let fileInfos = filter (\(path, _) -> not $ isIgnored path) $+ dropSndMaybes . F.toList $+ Tree.zipPaths . (dirOfRoot Tree.:/) $+ filterExcludedDirs root repoTree+ return $ RepoInfo (M.fromList fileInfos)+ where+ rootNE = if null root then "." else root+ dirOfRoot = if root == "" || root == "." then "" else takeDirectory root+ processFile file = do+ let ext = takeExtension file+ let mscanner = formatsSupport ext+ forM mscanner $ \scanFile ->+ scanFile file+ dropSndMaybes l = [(a, b) | (a, Just b) <- l]++ ignored = map (root </>) (tcIgnored config)+ isIgnored path = any (`isPrefixOf` path) ignored+ filterExcludedDirs cur = \case+ Tree.Dir name subfiles ->+ let subfiles' =+ if isIgnored cur+ then []+ else map visitRec subfiles+ visitRec sub = filterExcludedDirs (cur </> Tree.name sub) sub+ in Tree.Dir name subfiles'+ file@Tree.File{} -> file+ Tree.Failed _name err ->+ errorWithoutStackTrace $ "Repository traversal failed: " <> show err
+ src/Xrefcheck/Scanners.hs view
@@ -0,0 +1,6 @@+{- SPDX-FileCopyrightText: 2018-2019 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Xrefcheck/Scanners/Markdown.hs view
@@ -0,0 +1,102 @@+{- SPDX-FileCopyrightText: 2018-2019 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Markdown documents markdownScanner.++module Xrefcheck.Scanners.Markdown+ ( markdownScanner+ , markdownSupport+ ) where++import CMarkGFM (Node (..), NodeType (..), PosInfo (..), commonmarkToNode)+import Control.Lens ((%=))+import qualified Data.ByteString.Lazy as BSL+import Data.Default (Default (..))+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import Fmt (Buildable (..), blockListF, nameF, (+|), (|+))+import GHC.Conc (par)++import Xrefcheck.Core+import Xrefcheck.Scan++instance Buildable Node where+ build (Node _mpos ty subs) = nameF (show ty) $ blockListF subs++toPosition :: Maybe PosInfo -> Position+toPosition = Position . \case+ Nothing -> Nothing+ Just PosInfo{..}+ | startLine == endLine -> Just $+ startLine |+ ":" +| startColumn |+ "-" +| endColumn |+ ""+ | otherwise -> Just $+ " " +|+ startLine |+ ":" +| startColumn |+ " - " +|+ endLine |+ ":" +| endColumn |+ ""++nodeFlatten :: Node -> [NodeType]+nodeFlatten (Node _pos ty subs) = ty : concatMap nodeFlatten subs++nodeExtractText :: Node -> Text+nodeExtractText = mconcat . map extractText . nodeFlatten+ where+ extractText = \case+ TEXT t -> t+ CODE t -> t+ _ -> ""++nodeExtractInfo :: Node -> ExceptT Text Identity FileInfo+nodeExtractInfo docNode = fmap finaliseFileInfo $ execStateT (loop docNode) def+ where+ loop node@(Node pos ty subs) = case ty of+ DOCUMENT ->+ mapM_ loop subs+ PARAGRAPH ->+ mapM_ loop subs+ HEADING lvl ->+ let text = nodeExtractText node+ aType = HeaderAnchor lvl+ aName = headerToAnchor text+ aPos = toPosition pos+ in fiAnchors %= (Anchor{..} :)+ LIST _ ->+ mapM_ loop subs+ ITEM ->+ mapM_ loop subs+ HTML_INLINE htmlText -> do+ let mName = T.stripSuffix "\">" =<< T.stripPrefix "<a name=\"" htmlText+ whenJust mName $ \aName -> do+ let aType = HandAnchor+ aPos = toPosition pos+ fiAnchors %= (Anchor{..} :)+ LINK url _ -> do+ 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"+ fiReferences %= (Reference{..} :)+ _ -> pass++parseFileInfo :: FilePath -> LT.Text -> FileInfo+parseFileInfo path input =+ let outcome = runIdentity . runExceptT $+ nodeExtractInfo $ commonmarkToNode [] [] $ toStrict input+ in case outcome of+ Left err -> error $ "Failed to parse file " <> show path <>+ ": " <> show err+ Right res -> res++markdownScanner :: ScanAction+markdownScanner path = liftIO $ do+ res <- parseFileInfo path . decodeUtf8 <$> BSL.readFile path+ force res `par` return res++markdownSupport :: ([Extension], ScanAction)+markdownSupport = ([".md"], markdownScanner)
+ src/Xrefcheck/System.hs view
@@ -0,0 +1,29 @@+{- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++module Xrefcheck.System+ ( readingSystem+ , CanonicalizedGlobPattern (..)+ ) where++import Data.Aeson (FromJSON (..), withText)+import GHC.IO.Unsafe (unsafePerformIO)+import System.Directory (canonicalizePath)+import qualified System.FilePath.Glob as Glob++-- | 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++-- | Glob pattern with 'canonicalizePath' applied O_o.+newtype CanonicalizedGlobPattern = CanonicalizedGlobPattern Glob.Pattern++instance FromJSON CanonicalizedGlobPattern where+ parseJSON = withText "Repo-rooted glob pattern" $ \path -> do+ let !cpath = readingSystem $ canonicalizePath (toString path)+ cpat <- Glob.tryCompileWith Glob.compDefault cpath+ & either fail pure+ return $ CanonicalizedGlobPattern cpat
+ src/Xrefcheck/Util.hs view
@@ -0,0 +1,26 @@+{- SPDX-FileCopyrightText: 2018-2019 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Xrefcheck.Util+ ( nameF'+ , paren+ ) where++import Fmt (Builder, build, fmt, nameF)+import System.Console.Pretty (Pretty (..), Style (Faint))++instance Pretty Builder where+ colorize s c = build @Text . colorize s c . fmt+ style s = build @Text . style s . fmt++nameF' :: Builder -> Builder -> Builder+nameF' a b = nameF (style Faint a) b++paren :: Builder -> Builder+paren a+ | a == "" = ""+ | otherwise = "(" <> a <> ")"
+ src/Xrefcheck/Verify.hs view
@@ -0,0 +1,290 @@+{- SPDX-FileCopyrightText: 2018-2019 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}++module Xrefcheck.Verify+ ( -- * General verification+ VerifyResult (..)+ , verifyOk+ , verifyErrors+ , verifying++ , WithReferenceLoc (..)++ -- * Cross-references validation+ , VerifyError (..)+ , verifyRepo+ , checkExternalResource+ ) where++import Control.Concurrent.Async (forConcurrently, withAsync)+import Control.Monad.Except (ExceptT, MonadError (..))+import qualified Data.Map as M+import qualified Data.Text as T+import Data.Text.Metrics (damerauLevenshteinNorm)+import Fmt (Buildable (..), blockListF', listF, (+|), (|+))+import qualified GHC.Exts as Exts+import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), responseStatus)+import Network.HTTP.Req (GET (..), HEAD (..), HttpException (..), NoReqBody (..), defaultHttpConfig,+ ignoreResponse, parseUrl, req, runReq)+import Network.HTTP.Types.Status (Status, statusCode, statusMessage)+import System.Console.Pretty (Style (..), style)+import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist)+import qualified System.FilePath.Glob as Glob+import System.FilePath.Posix (takeDirectory, (</>))+import Time (RatioNat, Second, Time (..), ms, threadDelay, timeout)++import Xrefcheck.Config+import Xrefcheck.Core+import Xrefcheck.Progress+import Xrefcheck.System++{-# ANN module ("HLint: ignore Use uncurry" :: Text) #-}+{-# ANN module ("HLint: ignore Use 'runExceptT' from Universum" :: Text) #-}++-----------------------------------------------------------+-- General verification+-----------------------------------------------------------++newtype VerifyResult e = VerifyResult [e]+ deriving (Show, Functor)++deriving instance Semigroup (VerifyResult e)+deriving instance Monoid (VerifyResult e)++instance Buildable e => Buildable (VerifyResult e) where+ build vr = case verifyErrors vr of+ Nothing -> "ok"+ Just errs -> listF errs++verifyOk :: VerifyResult e -> Bool+verifyOk (VerifyResult errors) = null errors++verifyErrors :: VerifyResult e -> Maybe (NonEmpty e)+verifyErrors (VerifyResult errors) = nonEmpty errors++verifying :: Monad m => ExceptT e m () -> m (VerifyResult e)+verifying (ExceptT action) = fmap toVerifyRes action++toVerifyRes :: Either e () -> VerifyResult e+toVerifyRes = VerifyResult . either one (\() -> [])++-----------------------------------------------------------+-- Cross-references validation+-----------------------------------------------------------++data WithReferenceLoc a = WithReferenceLoc+ { wrlFile :: FilePath+ , wrlReference :: Reference+ , wrlItem :: a+ }++instance Buildable a => Buildable (WithReferenceLoc a) where+ build WithReferenceLoc{..} =+ "In file " +| style Faint (style Bold wrlFile) |+ "\nbad " +| wrlReference |+ "\n"+ +| wrlItem |+ "\n\n"++data VerifyError+ = FileDoesNotExist FilePath+ | AnchorDoesNotExist Text [Anchor]+ | AmbiguousAnchorRef FilePath Text (NonEmpty Anchor)+ | ExternalResourceInvalidUri+ | ExternalResourceUnavailable Status+ | ExternalResourceSomeError Text+ deriving (Show)++instance Buildable VerifyError where+ build = \case+ FileDoesNotExist file ->+ "⛀ File does not exist:\n " +| file |+ "\n"+ AnchorDoesNotExist anchor similar ->+ "⛀ Anchor '" +| anchor |+ "' is not present" +|+ anchorHints similar+ 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"+ ExternalResourceInvalidUri ->+ "⛂ Bad url (expected 'http' or 'https')\n"+ ExternalResourceUnavailable status ->+ "⛂ Resource unavailable (" +| statusCode status |+ " " +|+ decodeUtf8 @Text (statusMessage status) |+ ")\n"+ 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++verifyRepo+ :: Rewrite+ -> VerifyConfig+ -> VerifyMode+ -> FilePath+ -> RepoInfo+ -> IO (VerifyResult $ WithReferenceLoc VerifyError)+verifyRepo rw config@VerifyConfig{..} mode root repoInfo'@(RepoInfo repoInfo) = do+ let toScan = do+ (file, fileInfo) <- M.toList repoInfo+ guard . not $ any ((`isPrefixOf` file) . (root </>)) vcNotScanned+ ref <- _fiReferences fileInfo+ return (file, ref)++ progressRef <- newIORef $ initVerifyProgress (map snd toScan)++ withAsync (printer progressRef) $ \_ ->+ fmap fold . forConcurrently toScan $ \(file, ref) ->+ verifyReference config mode progressRef repoInfo' root file ref+ where+ printer progressRef = forever $ do+ readIORef progressRef >>= reprintAnalyseProgress rw mode+ threadDelay (ms 100)++shouldCheckLocType :: VerifyMode -> LocationType -> Bool+shouldCheckLocType mode locType+ | isExternal locType = shouldCheckExternal mode+ | isLocal locType = shouldCheckLocal mode+ | otherwise = False++verifyReference+ :: VerifyConfig+ -> VerifyMode+ -> IORef VerifyProgress+ -> RepoInfo+ -> FilePath+ -> FilePath+ -> Reference+ -> IO (VerifyResult $ WithReferenceLoc VerifyError)+verifyReference config@VerifyConfig{..} mode progressRef (RepoInfo repoInfo)+ root fileWithReference ref@Reference{..} = do++ let locType = locationType rLink++ if shouldCheckLocType mode locType+ then do+ res <- case locType of+ LocalLoc -> checkRef rAnchor fileWithReference+ RelativeLoc -> checkRef rAnchor+ (takeDirectory fileWithReference+ </> toString (canonizeLocalRef rLink))+ AbsoluteLoc -> checkRef rAnchor (root <> toString rLink)+ ExternalLoc -> checkExternalResource config rLink+ OtherLoc -> verifying pass++ let moveProgress =+ incProgress .+ (if verifyOk res then id else incProgressErrors)++ atomicModifyIORef' progressRef $ \VerifyProgress{..} ->+ ( if isExternal locType+ then VerifyProgress{ vrExternal = moveProgress vrExternal, .. }+ else VerifyProgress{ vrLocal = moveProgress vrLocal, .. }+ , ()+ )+ return $ fmap (WithReferenceLoc fileWithReference ref) res+ else return mempty+ where+ checkRef mAnchor referredFile = verifying $ do+ checkReferredFileExists referredFile+ case M.lookup referredFile repoInfo of+ Nothing -> pass -- no support for such file, can do nothing+ Just referredFileInfo ->+ whenJust mAnchor $ checkAnchor referredFile (_fiAnchors referredFileInfo)++ checkReferredFileExists file = do+ let fileExists = readingSystem $ doesFileExist file+ let dirExists = readingSystem $ doesDirectoryExist file++ let cfile = readingSystem $ canonicalizePath file+ let isVirtual = or+ [ Glob.match pat cfile+ | CanonicalizedGlobPattern pat <- vcVirtualFiles ]++ unless (fileExists || dirExists || isVirtual) $+ throwError (FileDoesNotExist file)++ checkAnchor file fileAnchors anchor = do+ checkAnchorReferenceAmbiguity file fileAnchors anchor+ checkDeduplicatedAnchorReference file fileAnchors anchor+ checkAnchorExists fileAnchors anchor++ -- 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+ when (length similarAnchors > 1) $+ throwError $ AmbiguousAnchorRef file anchor (Exts.fromList similarAnchors)++ -- Similar to the previous one, but for the case when we reference the+ -- renamed duplicate.+ checkDeduplicatedAnchorReference file fileAnchors anchor =+ whenJust (stripAnchorDupNo anchor) $ \origAnchor ->+ checkAnchorReferenceAmbiguity file fileAnchors origAnchor++ checkAnchorExists givenAnchors anchor =+ case find ((== anchor) . aName) givenAnchors of+ Just _ -> pass+ Nothing ->+ let isSimilar = (>= vcAnchorSimilarityThreshold)+ similarAnchors =+ filter (isSimilar . realToFrac . damerauLevenshteinNorm anchor . aName)+ givenAnchors+ in throwError $ AnchorDoesNotExist anchor similarAnchors++checkExternalResource :: VerifyConfig+ -> Text+ -> IO (VerifyResult VerifyError)+checkExternalResource VerifyConfig{..} link+ | doesReferLocalhost = return mempty+ | otherwise = fmap toVerifyRes $ do+ makeRequest HEAD 0.3 >>= \case+ Right () -> return $ Right ()+ Left _ -> makeRequest GET 0.7+ where+ doesReferLocalhost = any (`T.isInfixOf` link) ["://localhost", "://127.0.0.1"]++ makeRequest :: _ => method -> RatioNat -> IO (Either VerifyError ())+ makeRequest method timeoutFrac = runExceptT $ do+ parsedUrl <- parseUrl (encodeUtf8 link)+ & maybe (throwError ExternalResourceInvalidUri) pure+ let reqLink = case parsedUrl of+ Left (url, option) ->+ runReq defaultHttpConfig $+ req method url NoReqBody ignoreResponse option+ Right (url, option) ->+ runReq defaultHttpConfig $+ req method url NoReqBody ignoreResponse option++ let maxTime = Time @Second $ unTime vcExternalRefCheckTimeout * timeoutFrac++ mres <- liftIO (timeout maxTime $ void reqLink)+ `catch` (either throwError (\() -> return (Just ())) . interpretErrors)+ maybe (throwError $ ExternalResourceSomeError "Response timeout") pure mres++ 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.+ [ (403 ==) -- unauthorized access+ , (405 ==) -- method mismatch+ ]++ interpretErrors = \case+ JsonHttpException _ -> error "External link JSON parse exception"+ VanillaHttpException err -> case err of+ InvalidUrlException{} -> error "External link URL invalid exception"+ HttpExceptionRequest _ exc -> case exc of+ StatusCodeException resp _+ | isAllowedErrorCode (statusCode $ responseStatus resp) -> Right ()+ | otherwise -> Left $ ExternalResourceUnavailable (responseStatus resp)+ other -> Left . ExternalResourceSomeError $ show other
+ tests/Main.hs view
@@ -0,0 +1,10 @@+{- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++import Spec (spec)+import Test.Hspec (hspec)++main :: IO ()+main = hspec spec
+ tests/Spec.hs view
@@ -0,0 +1,6 @@+{- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
+ tests/Test/Xrefcheck/AnchorsSpec.hs view
@@ -0,0 +1,50 @@+{- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++module Test.Xrefcheck.AnchorsSpec where++import Test.Hspec (Spec, describe, it)+import Test.QuickCheck ((===))++import Xrefcheck.Core (headerToAnchor)++spec :: Spec+spec = do+ describe "Header-to-anchor conversion" $+ mapM_ (\(a, b) -> it (show a <> " == " <> show b) $ headerToAnchor a === b) $+ [ ( "Some header"+ , "some-header"+ )+ , ( "Do +5 times"+ , "do-5-times"+ )+ , ( "a # b"+ , "a--b"+ )+ , ( "a ## b"+ , "a--b"+ )+ , ( "a * b"+ , "a--b"+ )+ , ( "a / b"+ , "a--b"+ )+ , ( "a \\ b"+ , "a--b"+ )+ , ( "Some *italic* text"+ , "some-italic-text"+ )+ , ( "Some-text-with--many----hyphens"+ , "some-text-with--many----hyphens"+ )+ , ( "Some-+++++--mess++-mda"+ , "some---mess-mda"+ )+ , ( ":white_check_mark: Checklist for your Pull Request"+ , "white_check_mark-checklist-for-your-pull-request"+ )+ ]
+ tests/Test/Xrefcheck/ConfigSpec.hs view
@@ -0,0 +1,16 @@+{- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++module Test.Xrefcheck.ConfigSpec where++import Test.Hspec (Spec, it)+import Test.QuickCheck (ioProperty, once)++import Xrefcheck.Config++spec :: Spec+spec =+ it "Default config is valid" $+ once . ioProperty $ evaluateWHNF_ @_ @Config defConfig
+ tests/Test/Xrefcheck/LocalSpec.hs view
@@ -0,0 +1,23 @@+{- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++module Test.Xrefcheck.LocalSpec where++import Test.Hspec (Spec, describe, it)+import Test.QuickCheck ((===))++import Xrefcheck.Core (canonizeLocalRef)++spec :: Spec+spec = do+ describe "Local refs canonizing" $ do+ it "Strips ./" $+ canonizeLocalRef "./AnchorsSpec.hs" === "AnchorsSpec.hs"++ it "Strips ././" $+ canonizeLocalRef "././AnchorsSpec.hs" === "AnchorsSpec.hs"++ it "Leaves plain other intact" $+ canonizeLocalRef "../AnchorsSpec.hs" === "../AnchorsSpec.hs"
+ xrefcheck.cabal view
@@ -0,0 +1,176 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 7e709817763e8a6ce4c21d58175267e5326dd39a1902a4685e2379a2c1442a84++name: xrefcheck+version: 0.1.0.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+author: Kostya Ivanov, Serokell+maintainer: Serokell <hi@serokell.io>+copyright: 2018-2019 Serokell <https://serokell.io>+license: MPL-2.0+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ CHANGES.md+ src-files/def-config.yaml++source-repository head+ type: git+ location: https://github.com/serokell/xrefcheck++library+ exposed-modules:+ Xrefcheck.CLI+ Xrefcheck.Config+ Xrefcheck.Core+ Xrefcheck.Progress+ Xrefcheck.Scan+ Xrefcheck.Scanners+ Xrefcheck.Scanners.Markdown+ Xrefcheck.System+ Xrefcheck.Util+ Xrefcheck.Verify+ other-modules:+ Paths_xrefcheck+ hs-source-dirs:+ src+ default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveGeneric FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies UndecidableInstances ViewPatterns TypeApplications TypeOperators+ ghc-options: -Wall -Wincomplete-record-updates+ build-tool-depends:+ autoexporter:autoexporter+ build-depends:+ Glob+ , aeson+ , aeson-options+ , async+ , base-noprelude+ , bytestring+ , cmark-gfm+ , containers+ , data-default+ , deepseq+ , directory+ , directory-tree+ , filepath+ , fmt+ , http-client+ , http-types+ , lens+ , loot-prelude+ , mtl+ , o-clock+ , optparse-applicative+ , pretty-terminal+ , req+ , roman-numerals+ , template-haskell+ , text+ , text-metrics+ , th-lift-instances+ , th-utilities+ , yaml+ default-language: Haskell2010++executable xrefcheck+ main-is: Main.hs+ other-modules:+ Paths_xrefcheck+ hs-source-dirs:+ exec+ default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveGeneric FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies UndecidableInstances ViewPatterns TypeApplications TypeOperators+ ghc-options: -Wall -Wincomplete-record-updates -threaded -rtsopts -with-rtsopts=-N -O2+ build-tool-depends:+ autoexporter:autoexporter+ build-depends:+ Glob+ , aeson+ , aeson-options+ , async+ , base-noprelude+ , bytestring+ , cmark-gfm+ , containers+ , data-default+ , deepseq+ , directory+ , directory-tree+ , filepath+ , fmt+ , http-client+ , http-types+ , lens+ , loot-prelude+ , mtl+ , o-clock+ , optparse-applicative+ , pretty-terminal+ , req+ , roman-numerals+ , template-haskell+ , text+ , text-metrics+ , th-lift-instances+ , th-utilities+ , xrefcheck+ , yaml+ default-language: Haskell2010++test-suite xrefcheck-tests+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Spec+ Test.Xrefcheck.AnchorsSpec+ Test.Xrefcheck.ConfigSpec+ Test.Xrefcheck.LocalSpec+ Paths_xrefcheck+ hs-source-dirs:+ tests+ default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveGeneric FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies UndecidableInstances ViewPatterns TypeApplications TypeOperators+ ghc-options: -Wall -Wincomplete-record-updates+ build-tool-depends:+ autoexporter:autoexporter+ , hspec-discover:hspec-discover+ build-depends:+ Glob+ , QuickCheck+ , aeson+ , aeson-options+ , async+ , base-noprelude+ , bytestring+ , cmark-gfm+ , containers+ , data-default+ , deepseq+ , directory+ , directory-tree+ , filepath+ , fmt+ , hspec+ , http-client+ , http-types+ , lens+ , loot-prelude+ , mtl+ , o-clock+ , optparse-applicative+ , pretty-terminal+ , req+ , roman-numerals+ , template-haskell+ , text+ , text-metrics+ , th-lift-instances+ , th-utilities+ , xrefcheck+ , yaml+ default-language: Haskell2010