xrefcheck 0.2 → 0.2.1
raw patch · 31 files changed
+2791/−1297 lines, 31 filesdep +case-insensitivedep +dlistdep +exceptionsdep −deepseqdep −file-embeddep −template-haskelldep ~base
Dependencies added: case-insensitive, dlist, exceptions, firefly, ftp-client, hspec-expectations, raw-strings-qq, tagged, tagsoup, tasty, tasty-hunit, time, uri-bytestring
Dependencies removed: deepseq, file-embed, template-haskell, th-utilities
Dependency ranges changed: base
Files
- CHANGES.md +51/−1
- README.md +6/−4
- exec/Main.hs +12/−74
- links-tests/Main.hs +21/−0
- links-tests/Test/Xrefcheck/FtpLinks.hs +84/−0
- links-tests/Tree.hs +5/−0
- src-files/def-config.yaml +0/−49
- src/Xrefcheck/CLI.hs +164/−110
- src/Xrefcheck/Command.hs +90/−0
- src/Xrefcheck/Config.hs +157/−80
- src/Xrefcheck/Config/Default.hs +71/−0
- src/Xrefcheck/Core.hs +147/−136
- src/Xrefcheck/Orphans.hs +65/−0
- src/Xrefcheck/Progress.hs +188/−60
- src/Xrefcheck/Scan.hs +95/−51
- src/Xrefcheck/Scanners/Markdown.hs +303/−199
- src/Xrefcheck/System.hs +32/−16
- src/Xrefcheck/Util.hs +39/−10
- src/Xrefcheck/Verify.hs +518/−205
- tests/Main.hs +2/−0
- tests/Test/Xrefcheck/AnchorsInHeadersSpec.hs +27/−0
- tests/Test/Xrefcheck/AnchorsSpec.hs +117/−105
- tests/Test/Xrefcheck/ConfigSpec.hs +53/−15
- tests/Test/Xrefcheck/IgnoreAnnotationsSpec.hs +41/−42
- tests/Test/Xrefcheck/IgnoreRegexSpec.hs +54/−51
- tests/Test/Xrefcheck/LocalSpec.hs +9/−7
- tests/Test/Xrefcheck/TooManyRequestsSpec.hs +217/−0
- tests/Test/Xrefcheck/TrailingSlashSpec.hs +48/−0
- tests/Test/Xrefcheck/URIParsingSpec.hs +53/−0
- tests/Test/Xrefcheck/Util.hs +26/−0
- xrefcheck.cabal +96/−82
CHANGES.md view
@@ -1,5 +1,5 @@ <!--- - SPDX-FileCopyrightText: 2020 Serokell <https://serokell.io>+ - SPDX-FileCopyrightText: 2021 Serokell <https://serokell.io> - - SPDX-License-Identifier: MPL-2.0 -->@@ -7,8 +7,58 @@ Unreleased ========== +0.2.1+==========++* [#127](https://github.com/serokell/xrefcheck/pull/127)+ + Support `Retry-After` headers with dates.+* [#117](https://github.com/serokell/xrefcheck/pull/117)+ + Forbid verifying a single file using `--root` command line option.+* [#115](https://github.com/serokell/xrefcheck/pull/115)+ + Improved parsing of anchor html tags inside headers.+* [#109](https://github.com/serokell/xrefcheck/pull/109)+ + Fixed bug when prefixing `--ignored` and `--root` paths with `./`+* [#85](https://github.com/serokell/xrefcheck/pull/85)+ + 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.+* [#66](https://github.com/serokell/xrefcheck/pull/66)+ + Added support for ftp links.+* [#74](https://github.com/serokell/xrefcheck/pull/83)+ + Add the duplication detection & verification result caching algorithm for external references.+* [#82](https://github.com/serokell/xrefcheck/pull/82)+ + Fix the issue of having the lowest level context duplicated, caused by the root's trailing path separator.+* [#88](https://github.com/serokell/xrefcheck/pull/88)+ + Handle the "429 too many requests" errors & attempt to eliminate them during verification.+* [#128](https://github.com/serokell/xrefcheck/pull/128)+ + Make `ignoreRefs` a required parameter.+* [#129](https://github.com/serokell/xrefcheck/pull/129)+ + Add support for the `id` attribute in anchors.+* [#116](https://github.com/serokell/xrefcheck/pull/116)+ + Allow certain reserved characters to be present in the query strings of the URLs.+* [#130](https://github.com/serokell/xrefcheck/pull/130)+ + Fixed bug with ignoring checks for relative anchors.+* [#132](https://github.com/serokell/xrefcheck/pull/132)+ + Display URL parsing errors.+* [#131](https://github.com/serokell/xrefcheck/pull/131)+ + Add support for glob patterns to `ignored` and `notScanned`.+ + Remove support for directory names from `ignored` and `notScanned`.+ + Fix bug with `ignored` not ignoring files with broken xrefcheck annotations.+* [#142](https://github.com/serokell/xrefcheck/pull/142)+ + Remove `check-localhost` CLI option and `checkLocalhost` config option.+ + Add a regex matching localhost links to the `ignoreRefs` field of the default config.+* [#68](https://github.com/serokell/xrefcheck/pull/68)+ + Recognise manual HTML-anchors inside headers.+* [#141](https://github.com/serokell/xrefcheck/pull/141)+ + Dump all the errors from different files.+ + Fix bug where no errors were reported about broken link annotation and unrecognised annotation.+* [#159](https://github.com/serokell/xrefcheck/pull/159)+ + Make all config options optional.+ 0.2 ==========+ * [#57](https://github.com/serokell/xrefcheck/pull/57) + Added `flavor` field to config. Also see [config sample](tests/configs/github-config.yaml).
README.md view
@@ -1,5 +1,5 @@ <!--- - SPDX-FileCopyrightText: 2018-2019 Serokell <https://serokell.io>+ - SPDX-FileCopyrightText: 2018-2021 Serokell <https://serokell.io> - - SPDX-License-Identifier: MPL-2.0 -->@@ -36,7 +36,7 @@ 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.+ 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.@@ -45,6 +45,7 @@ * [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. +At the moment of writing, the listed solutions don't support ftp/ftps links. ## Usage [↑](#xrefcheck) @@ -83,7 +84,7 @@ 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 optional `ignoreRefs` parameter of your config file.+1. Add the regular expression that matches the ignoring link to the `ignoreRefs` parameter of your config file. For example: ```yaml@@ -158,11 +159,12 @@ Currently supported options include: * Timeout for checking external references;-* List of ignored folders.+* List of ignored files. ## Build instructions [↑](#xrefcheck) 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! ### CI and nix [↑](#xrefcheck)
exec/Main.hs view
@@ -5,82 +5,20 @@ module Main where -import qualified Data.ByteString as BS-import Data.Yaml (decodeFileEither, prettyPrintParseException)-import Fmt (blockListF', build, fmt, fmtLn, indentF)-import Main.Utf8 (withUtf8)-import System.Directory (doesFileExist)--import Xrefcheck.CLI-import Xrefcheck.Config-import Xrefcheck.Core-import Xrefcheck.Progress-import Xrefcheck.Scan-import Xrefcheck.Scanners-import Xrefcheck.System-import Xrefcheck.Verify--formats :: ScannersConfig -> FormatsSupport-formats ScannersConfig{..} = specificFormatsSupport- [ markdownSupport scMarkdown- ]--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 \- \for GitHub repositories\n"- pure $ defConfig GitHub- Just configPath ->- readConfig configPath- Just configPath -> do- readConfig configPath-- withinCI <- askWithinCI- let showProgressBar = oShowProgressBar ?: not withinCI-- repoInfo <- allowRewrite showProgressBar $ \rw -> do- let fullConfig = addTraversalOptions (cTraversal config) oTraversalOptions- gatherRepoInfo rw (formats $ cScanners config) fullConfig root-- when oVerbose $- fmtLn $ "=== Repository data ===\n\n" <> indentF 2 (build repoInfo)+import Universum - verifyRes <- allowRewrite showProgressBar $ \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+import Data.ByteString qualified as BS+import Main.Utf8 (withUtf8) - readConfig :: FilePath -> IO Config- readConfig path =- decodeFileEither path- >>= either (error . toText . prettyPrintParseException) pure+import Xrefcheck.CLI (Command (..), getCommand)+import Xrefcheck.Command (defaultAction)+import Xrefcheck.Config (defConfigText) main :: IO () main = withUtf8 $ do- command <- getCommand- case command of- DefaultCommand options ->- defaultAction options- DumpConfig repoType path ->- BS.writeFile path (defConfigText repoType)+ command <- getCommand+ case command of+ DefaultCommand options ->+ defaultAction options+ DumpConfig repoType path ->+ BS.writeFile path (defConfigText repoType)
+ links-tests/Main.hs view
@@ -0,0 +1,21 @@+-- SPDX-FileCopyrightText: 2021 Serokell <https://serokell.io>+--+-- SPDX-License-Identifier: MPL-2.0++module Main+ ( main+ ) where++import Universum++import Test.Tasty (defaultIngredients, defaultMainWithIngredients, includingOptions)+import Test.Tasty.Ingredients (Ingredient)++import Test.Xrefcheck.FtpLinks (ftpOptions)+import Tree (tests)++main :: IO ()+main = tests >>= defaultMainWithIngredients ingredients++ingredients :: [Ingredient]+ingredients = includingOptions ftpOptions : defaultIngredients
+ links-tests/Test/Xrefcheck/FtpLinks.hs view
@@ -0,0 +1,84 @@+-- SPDX-FileCopyrightText: 2021 Serokell <https://serokell.io>+--+-- SPDX-License-Identifier: MPL-2.0++module Test.Xrefcheck.FtpLinks+ ( ftpOptions+ , test_FtpLinks+ ) where++import Universum++import Data.Tagged (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)++-- | A list with all the options needed to configure FTP links tests.+ftpOptions :: [OptionDescription]+ftpOptions =+ [ Tasty.Option (Proxy @FtpHostOpt)+ ]++-- | Option specifying FTP host.+newtype FtpHostOpt = FtpHostOpt Text+ deriving stock (Show, Eq)++instance IsOption FtpHostOpt where+ defaultValue = FtpHostOpt "ftp://localhost"+ optionName = "ftp-host"+ 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))+ )+++config :: VerifyConfig+config = (cVerification $ defConfig GitHub) { vcIgnoreRefs = [] }++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 []++ , testCase "handles empty link (host only)" $ do+ let link = host+ result <- checkExternalResource config link+ result @?= VerifyResult []++ , testCase "handles correct link to non empty directory" $ do+ let link = host <> "/pub/"+ result <- checkExternalResource config link+ result @?= VerifyResult []++ , testCase "handles correct link to empty directory" $ do+ let link = host <> "/empty/"+ result <- checkExternalResource config link+ result @?= VerifyResult []++ , 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 ->+ assertFailure "No exception was raised, FtpEntryDoesNotExist expected"+ Just errors ->+ assertBool "Expected FtpEntryDoesNotExist, got other exceptions"+ (any (+ \case+ FtpEntryDoesNotExist _ -> True+ ExternalFtpException _ -> True+ _ -> False+ ) $ toList errors)+ ]
+ links-tests/Tree.hs view
@@ -0,0 +1,5 @@+-- SPDX-FileCopyrightText: 2021 Serokell <https://serokell.io>+--+-- SPDX-License-Identifier: MPL-2.0++{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display -optF --generated-module -optF Tree #-}
− src-files/def-config.yaml
@@ -1,49 +0,0 @@-# SPDX-FileCopyrightText: 2019-2021 Serokell <https://serokell.io>-#-# SPDX-License-Identifier: Unlicense--# Parameters of repository traversal.-traversal:- # Files and 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-- # Prefixes of files, references in which should not be analyzed.- notScanned:- - :PLACEHOLDER:notScanned:-- # Glob patterns describing the files which do not physically exist in the- # repository but should be treated as existing nevertheless.- virtualFiles:- - :PLACEHOLDER:virtualFiles:-- # POSIX extended regular expressions that match external references- # that have to be ignored (not verified).- # It is an optional parameter, so it can be omitted.- ignoreRefs:- []--# Parameters of scanners for various file types.-scanners:-- markdown:- # Flavor of markdown, e.g. GitHub-flavor.- #- # This affects which anchors are generated for headers.- flavor: :PLACEHOLDER:flavor:
src/Xrefcheck/CLI.hs view
@@ -6,61 +6,81 @@ {-# LANGUAGE ApplicativeDo #-} module Xrefcheck.CLI- ( VerifyMode (..)- , shouldCheckLocal- , shouldCheckExternal- , Command (..)- , Options (..)- , TraversalOptions (..)- , addTraversalOptions- , defaultConfigPaths- , getCommand- ) where+ ( VerifyMode (..)+ , shouldCheckLocal+ , shouldCheckExternal+ , Command (..)+ , Options (..)+ , VerifyOptions (..)+ , addVerifyOptions+ , TraversalOptions (..)+ , addTraversalOptions+ , defaultConfigPaths+ , getCommand+ ) where -import qualified Data.Char as C-import qualified Data.List as L-import qualified Data.Text as T+import Universum++import Data.Char qualified as C+import Data.List qualified as L+import Data.Text qualified as T import Data.Version (showVersion) import Options.Applicative- (Parser, ReadM, command, eitherReader, execParser, flag', footerDoc, fullDesc, help, helper,- hsubparser, info, infoOption, long, metavar, option, progDesc, short, strOption, switch, value)+ (Mod, OptionFields, Parser, ReadM, auto, command, eitherReader, execParser, 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 qualified as Pretty import Paths_xrefcheck (version)+import Xrefcheck.Config (VerifyConfig, VerifyConfig' (..)) import Xrefcheck.Core import Xrefcheck.Scan+import Xrefcheck.Util (normaliseWithNoTrailing)+import Xrefcheck.System (RelGlobPattern (..)) 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)- ]+ 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)+ ] +data ModeInfo = ModeInfo+ { miName :: String+ , miMode :: VerifyMode+ , miHelpText :: String+ }++modes :: [ModeInfo]+modes =+ [ ModeInfo "local-only" LocalOnlyMode+ "Verify only references to local files."+ , ModeInfo "external-only" ExternalOnlyMode+ "Verify only external references (e.g. http or ftp URLs)."+ , ModeInfo "full" FullMode+ "Verify all references."+ ]+ data Command = DefaultCommand Options | DumpConfig Flavor FilePath data Options = Options- { oConfigPath :: Maybe FilePath- , oRoot :: FilePath- , oMode :: VerifyMode- , oVerbose :: Bool- , oShowProgressBar :: Maybe Bool- , oTraversalOptions :: TraversalOptions- }+ { oConfigPath :: Maybe FilePath+ , oRoot :: FilePath+ , oMode :: VerifyMode+ , oVerbose :: Bool+ , oShowProgressBar :: Maybe Bool+ , oTraversalOptions :: TraversalOptions+ , oVerifyOptions :: VerifyOptions+ } data TraversalOptions = TraversalOptions- { toIgnored :: [FilePath]- }+ { toIgnored :: [RelGlobPattern]+ } addTraversalOptions :: TraversalConfig -> TraversalOptions -> TraversalConfig addTraversalOptions TraversalConfig{..} (TraversalOptions ignored) =@@ -69,6 +89,17 @@ , .. } +data VerifyOptions = VerifyOptions+ { voMaxRetries :: Maybe Int+ }++addVerifyOptions :: VerifyConfig -> VerifyOptions -> VerifyConfig+addVerifyOptions VerifyConfig{..} (VerifyOptions maxRetries) =+ VerifyConfig+ { vcMaxRetries = fromMaybe vcMaxRetries maxRetries+ , ..+ }+ -- | Where to try to seek configuration if specific path is not set. defaultConfigPaths :: [FilePath] defaultConfigPaths = ["./xrefcheck.yaml", "./.xrefcheck.yaml"]@@ -80,6 +111,12 @@ -- and flavors, so we write a type alias here. type RepoType = Flavor +filepathOption :: Mod OptionFields FilePath -> Parser FilePath+filepathOption = fmap normaliseWithNoTrailing <$> strOption++globOption :: Mod OptionFields FilePath -> Parser RelGlobPattern+globOption = fmap RelGlobPattern <$> filepathOption+ repoTypeReadM :: ReadM RepoType repoTypeReadM = eitherReader $ \name -> maybeToRight (failureText name) $ L.lookup (map C.toLower name) allRepoTypesNamed@@ -93,55 +130,70 @@ 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 <- asum- [ flag' (Just True) $- long "progress" <>- help "Display progress bar during verification. \- \This is enabled by default unless `CI` env var is set to true."- , flag' (Just False) $- long "no-progress" <>- help "Do not display progress bar during verification."- , pure Nothing- ]- oTraversalOptions <- traversalOptionsParser- return Options{..}+ oConfigPath <- optional . filepathOption $+ 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 <- filepathOption $+ short 'r' <>+ long "root" <>+ metavar "DIRECTORY" <>+ help "Path to repository root." <>+ value "."+ oMode <- option modeReadM $+ short 'm' <>+ long "mode" <>+ metavar "KEYWORD" <>+ value FullMode <>+ helpDoc+ ( Just $ Pretty.vsep $+ (modes <&> \mi -> fromString $ miName mi <> ": " <> miHelpText mi)+ <>+ [ "Default mode: full."]+ )+ oVerbose <- switch $+ short 'v' <>+ long "verbose" <>+ help "Report repository scan and verification details."+ oShowProgressBar <- asum+ [ flag' (Just True) $+ long "progress" <>+ help "Display progress bar during verification. \+ \This is enabled by default unless `CI` env var is set to true."+ , flag' (Just False) $+ long "no-progress" <>+ help "Do not display progress bar during verification."+ , pure Nothing+ ]+ oTraversalOptions <- traversalOptionsParser+ oVerifyOptions <- verifyOptionsParser+ return Options{..} traversalOptionsParser :: Parser TraversalOptions traversalOptionsParser = do- toIgnored <- many . strOption $- long "ignored" <>- metavar "FILEPATH" <>- help "Files and folders which we pretend do not exist."- return TraversalOptions{..}+ toIgnored <- many . globOption $+ long "ignored" <>+ metavar "GLOB PATTERN" <>+ help "Files which we pretend do not exist.\+ \ Glob patterns that contain wildcards MUST be enclosed\+ \ in quotes to avoid being expanded by shell."+ return TraversalOptions{..} +verifyOptionsParser :: Parser VerifyOptions+verifyOptionsParser = do+ voMaxRetries <- 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{..}+ dumpConfigOptions :: Parser Command dumpConfigOptions = hsubparser $ command "dump-config" $@@ -150,15 +202,17 @@ where parser = DumpConfig <$> repoTypeOption <*> outputOption + allRepoTypes = "(" <> intercalate " | " (map (show @String) allFlavors) <> ")"+ repoTypeOption = option repoTypeReadM $ short 't' <> long "type" <> metavar "REPOSITORY TYPE" <>- help "Git repository type."+ help ("Git repository type. Can be " <> allRepoTypes <> ". Case insensitive.") outputOption =- strOption $+ filepathOption $ short 'o' <> long "output" <> metavar "FILEPATH" <>@@ -173,41 +227,41 @@ versionOption :: Parser (a -> a) versionOption = infoOption ("xrefcheck-" <> showVersion version) $- long "version" <>- help "Show 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." <>- (footerDoc $ pure ignoreModesMsg)+ execParser $+ info (helper <*> versionOption <*> totalParser) $+ fullDesc <>+ progDesc "Cross-references verifier for markdown documentation in \+ \Git repositories." <>+ footerDoc (pure ignoreModesMsg) ignoreModesMsg :: Doc 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) ""+ 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+ pageWidth = 80+ pageParam = 1 - doc = fillSep $ map formatDesc modeDescr+ doc = fillSep $ map formatDesc modeDescr - modeDescr =- [ (" \"link\"", L.words $ "Ignore the link right after the comment.")- , (" \"paragraph\"", L.words $ "Ignore the whole paragraph after the comment.")- , (" \"file\"", L.words $ "This mode can only be used at the top of markdown \- \or right after comments at the top.")- ]+ modeDescr =+ [ (" \"link\"", L.words "Ignore the link right after the comment.")+ , (" \"paragraph\"", L.words "Ignore the whole paragraph after the comment.")+ , (" \"file\"", L.words "This mode can only be used at the top of \+ \markdown or right after comments at the top.")+ ] - modeIndent = length ("\"paragraph\"" :: String) + 2- descrIndent = 27 - modeIndent+ modeIndent = length ("\"paragraph\"" :: String) + 2+ descrIndent = 27 - modeIndent - formatDesc (mode, descr) =- (fill modeIndent $ text mode) <>- (indent descrIndent $ fillSep $ map text descr)+ formatDesc (mode, descr) =+ fill modeIndent (text mode) <>+ indent descrIndent (fillSep $ map text descr)
+ src/Xrefcheck/Command.hs view
@@ -0,0 +1,90 @@+{- SPDX-FileCopyrightText: 2021 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++module Xrefcheck.Command+ ( defaultAction+ ) where++import Universum++import Data.Yaml (decodeFileEither, prettyPrintParseException)+import Fmt (blockListF', build, fmt, fmtLn, indentF)+import System.Directory (doesFileExist)++import Xrefcheck.CLI (Options (..), addTraversalOptions, addVerifyOptions, defaultConfigPaths)+import Xrefcheck.Config+ (Config, Config' (..), ScannersConfig, ScannersConfig' (..), defConfig, normaliseConfigFilePaths,+ overrideConfig)+import Xrefcheck.Core (Flavor (..))+import Xrefcheck.Progress (allowRewrite)+import Xrefcheck.Scan (FormatsSupport, scanRepo, specificFormatsSupport, ScanResult (..), ScanError (..))+import Xrefcheck.Scanners.Markdown (markdownSupport)+import Xrefcheck.System (askWithinCI)+import Xrefcheck.Verify (verifyErrors, verifyRepo)++readConfig :: FilePath -> IO Config+readConfig path = fmap (normaliseConfigFilePaths . overrideConfig) do+ decodeFileEither path+ >>= either (error . toText . prettyPrintParseException) pure++formats :: ScannersConfig -> FormatsSupport+formats ScannersConfig{..} = specificFormatsSupport+ [ markdownSupport scMarkdown+ ]++findFirstExistingFile :: [FilePath] -> IO (Maybe FilePath)+findFirstExistingFile = \case+ [] -> pure Nothing+ (file : files) -> do+ exists <- doesFileExist file+ if exists then pure (Just file) else findFirstExistingFile files++defaultAction :: Options -> IO ()+defaultAction Options{..} = do+ config <- case oConfigPath of+ Just configPath -> readConfig configPath+ Nothing -> do+ mConfigPath <- findFirstExistingFile defaultConfigPaths+ case mConfigPath of+ Just configPath -> readConfig configPath+ Nothing -> do+ hPutStrLn @Text stderr+ "Configuration file not found, using default config \+ \for GitHub repositories\n"+ 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++ when oVerbose $+ fmtLn $ "=== Repository data ===\n\n" <> indentF 2 (build repoInfo)++ unless (null scanErrs) . reportScanErrs $ sortBy (compare `on` seFile) scanErrs++ verifyRes <- allowRewrite showProgressBar $ \rw -> do+ let fullConfig = addVerifyOptions (cVerification config) oVerifyOptions+ verifyRepo rw fullConfig oMode oRoot repoInfo++ case verifyErrors verifyRes of+ Nothing | null scanErrs -> fmtLn "All repository links are valid."+ Nothing -> exitFailure+ Just (toList -> verifyErrs) -> do+ fmt "\n\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
@@ -7,66 +7,91 @@ module Xrefcheck.Config where -import qualified Unsafe+import qualified Universum.Unsafe as Unsafe +import Universum+ import Control.Exception (assert) import Control.Lens (makeLensesWith)-import Data.Aeson.TH (deriveFromJSON)-import qualified Data.ByteString as BS-import qualified Data.Map as Map+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 (CompOption (..), ExecOption (..), Regex)-import qualified Text.Regex.TDFA as R+import Text.Regex.TDFA qualified as R import Text.Regex.TDFA.ByteString ()-import qualified Text.Regex.TDFA.Text as R+import Text.Regex.TDFA.Text qualified as R --- FIXME: Use </> from System.FilePath--- </> from Posix is used only because we cross-compile to Windows and \ doesn't work on Linux-import Data.FileEmbed (embedFile)-import System.FilePath.Posix ((</>))-import Time (KnownRatName, Second, Time, unitsP)+import Time (KnownRatName, Second, Time(..), unitsP) import Xrefcheck.Core import Xrefcheck.Scan import Xrefcheck.Scanners.Markdown-import Xrefcheck.System (RelGlobPattern)-import Xrefcheck.Util (aesonConfigOption, postfixFields, (-:))+import Xrefcheck.System (RelGlobPattern, normaliseGlobPattern)+import Xrefcheck.Util (aesonConfigOption, postfixFields, (-:), Field)+import Xrefcheck.Config.Default+import Text.Regex.TDFA.Common +-- | Type alias for Config' with all required fields.+type Config = Config' Identity++-- | Type alias for Config' with optional fields.+type ConfigOptional = Config' Maybe+ -- | Overall config.-data Config = Config- { cTraversal :: TraversalConfig- , cVerification :: VerifyConfig- , cScanners :: ScannersConfig+data Config' f = Config+ { cTraversal :: Field f (TraversalConfig' f)+ , cVerification :: Field f (VerifyConfig' f)+ , cScanners :: Field f (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+ -- | Config of verification.-data VerifyConfig = VerifyConfig- { vcAnchorSimilarityThreshold :: Double- , vcExternalRefCheckTimeout :: Time Second- , vcVirtualFiles :: [RelGlobPattern]- -- ^ Files which we pretend do exist.- , vcNotScanned :: [FilePath]- -- ^ Prefixes of files, references in which we should not analyze.- , vcIgnoreRefs :: Maybe [Regex]- -- ^ Regular expressions that match external references we should not verify.- }+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+ -- ^ 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)+ -- ^ Default Retry-After delay, applicable when we receive a 429 response+ -- and it does not contain a @Retry-After@ header.+ , vcMaxRetries :: Field f Int+ } deriving stock (Generic) --- | Configs for all the supported scanners.-data ScannersConfig = ScannersConfig- { scMarkdown :: MarkdownConfig+normaliseVerifyConfigFilePaths :: VerifyConfig -> VerifyConfig+normaliseVerifyConfigFilePaths vc@VerifyConfig{ vcVirtualFiles, vcNotScanned}+ = vc+ { vcVirtualFiles = map normaliseGlobPattern vcVirtualFiles+ , vcNotScanned = map normaliseGlobPattern vcNotScanned } -makeLensesWith postfixFields ''Config-makeLensesWith postfixFields ''VerifyConfig+-- | Type alias for ScannersConfig' with all required fields.+type ScannersConfig = ScannersConfig' Identity --------------------------------------------------------------- Default config------------------------------------------------------------+-- | Configs for all the supported scanners.+data ScannersConfig' f = ScannersConfig+ { scMarkdown :: Field f (MarkdownConfig' f)+ } deriving stock (Generic) -defConfigUnfilled :: ByteString-defConfigUnfilled =- $(embedFile ("src-files" </> "def-config.yaml"))+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@@ -76,7 +101,9 @@ -- the provided replacement won't cause any warnings or failures. fillHoles :: HasCallStack- => [(ByteString, Either ByteString [ByteString])] -> ByteString -> ByteString+ => [(ByteString, Either ByteString [ByteString])]+ -> ByteString+ -> ByteString fillHoles allReplacements rawConfig = let holesLocs = R.getAllMatches $ holeLineRegex `R.match` rawConfig in mconcat $ replaceHoles 0 holesLocs@@ -113,25 +140,25 @@ 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"+ 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"]+ 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@@ -150,12 +177,12 @@ GitHub -> [ ".github/pull_request_template.md" , ".github/issue_template.md"- , ".github/PULL_REQUEST_TEMPLATE"- , ".github/ISSUE_TEMPLATE"+ , ".github/PULL_REQUEST_TEMPLATE/**/*"+ , ".github/ISSUE_TEMPLATE/**/*" ] GitLab ->- [ ".gitlab/merge_request_templates/"- , ".gitlab/issue_templates/"+ [ ".gitlab/merge_request_templates/**/*"+ , ".gitlab/issue_templates/**/*" ] , "virtualFiles" -: Right $ case flavor of@@ -174,40 +201,90 @@ ] defConfig :: HasCallStack => Flavor -> Config-defConfig flavor =+defConfig flavor = normaliseConfigFilePaths $ either (error . toText . prettyPrintParseException) id $ decodeEither' (defConfigText flavor) +-- | Override missed fields with default values.+overrideConfig :: ConfigOptional -> Config+overrideConfig config+ = Config+ { cTraversal = TraversalConfig ignored+ , cVerification = maybe defVerification overrideVerify $ cVerification config+ , cScanners = ScannersConfig (MarkdownConfig flavor)+ }+ where+ flavor = fromMaybe GitHub+ $ mcFlavor =<< scMarkdown =<< cScanners config++ defTraversal = cTraversal $ defConfig flavor++ ignored = fromMaybe (tcIgnored defTraversal) $ tcIgnored =<< cTraversal config++ defVerification = cVerification $ defConfig flavor++ overrideVerify verifyConfig+ = VerifyConfig+ { vcAnchorSimilarityThreshold = fromMaybe (vcAnchorSimilarityThreshold defVerification)+ $ vcAnchorSimilarityThreshold verifyConfig+ , vcExternalRefCheckTimeout = fromMaybe (vcExternalRefCheckTimeout defVerification)+ $ vcExternalRefCheckTimeout verifyConfig+ , vcVirtualFiles = fromMaybe (vcVirtualFiles defVerification)+ $ vcVirtualFiles verifyConfig+ , vcNotScanned = fromMaybe (vcNotScanned defVerification)+ $ vcNotScanned verifyConfig+ , vcIgnoreRefs = fromMaybe (vcIgnoreRefs defVerification)+ $ vcIgnoreRefs verifyConfig+ , vcIgnoreAuthFailures = fromMaybe (vcIgnoreAuthFailures defVerification)+ $ vcIgnoreAuthFailures verifyConfig+ , vcDefaultRetryAfter = fromMaybe (vcDefaultRetryAfter defVerification)+ $ vcDefaultRetryAfter verifyConfig+ , vcMaxRetries = fromMaybe (vcMaxRetries defVerification)+ $ vcMaxRetries verifyConfig+ }+ ----------------------------------------------------------- -- Yaml instances ----------------------------------------------------------- -deriveFromJSON aesonConfigOption ''Config-deriveFromJSON aesonConfigOption ''ScannersConfig-deriveFromJSON aesonConfigOption ''VerifyConfig- instance KnownRatName unit => FromJSON (Time unit) where- parseJSON = withText "time" $- maybe (fail "Unknown time") pure . unitsP . toString+ 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+ 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- }+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+ parseJSON = genericParseJSON aesonConfigOption++instance FromJSON (VerifyConfig) where+ parseJSON = genericParseJSON aesonConfigOption++instance FromJSON (ScannersConfig' Maybe) where+ parseJSON = genericParseJSON aesonConfigOption++instance FromJSON (ScannersConfig) where+ parseJSON = genericParseJSON aesonConfigOption
+ src/Xrefcheck/Config/Default.hs view
@@ -0,0 +1,71 @@+{- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io>+ -+ - 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:+ # 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++ # Glob patterns describing the files, references in which should not be analyzed.+ notScanned:+ - :PLACEHOLDER:notScanned:++ # Glob patterns describing the files which do not physically exist in the+ # repository but should be treated as existing nevertheless.+ virtualFiles:+ - :PLACEHOLDER:virtualFiles:++ # POSIX extended regular expressions that match external references+ # that have to be ignored (not verified).+ ignoreRefs:+ # Ignore localhost links by default+ - ^(https?|ftps?)://(localhost|127\.0\.0\.1).*++ # Skip links which return 403 or 401 code.+ ignoreAuthFailures: true++ # When a verification result is a "429 Too Many Requests" response+ # and it does not contain a "Retry-After" header,+ # wait this amount of time before attempting to verify the link again.+ defaultRetryAfter: 30s++ # How many attempts to retry an external link after getting+ # a "429 Too Many Requests" response.+ maxRetries: 3++# Parameters of scanners for various file types.+scanners:+ markdown:+ # Flavor of markdown, e.g. GitHub-flavor.+ #+ # This affects which anchors are generated for headers.+ flavor: :PLACEHOLDER:flavor:+|]
src/Xrefcheck/Core.hs view
@@ -9,21 +9,26 @@ module Xrefcheck.Core where -import Control.Lens (makeLenses, (%=))+import Universum++import Control.Lens (makeLenses) import Data.Aeson (FromJSON (..), withText) import Data.Char (isAlphaNum)-import qualified Data.Char as C+import Data.Char qualified 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 Data.List qualified as L+import Data.Map qualified as M+import Data.Text qualified as T import Fmt (Buildable (..), blockListF, blockListF', nameF, (+|), (|+)) import System.Console.Pretty (Color (..), Style (..), color, style) import System.FilePath (isPathSeparator, pathSeparator) import Text.Numeral.Roman (toRoman)+import Time (Second, Time) import Xrefcheck.Progress import Xrefcheck.Util+import Data.DList (DList)+import Data.DList qualified as DList ----------------------------------------------------------- -- Types@@ -36,7 +41,7 @@ data Flavor = GitHub | GitLab- deriving (Show)+ deriving stock (Show) allFlavors :: [Flavor] allFlavors = [GitHub, GitLab]@@ -57,58 +62,69 @@ -- 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)+ deriving stock (Show, Eq, Generic) instance Buildable Position where- build (Position pos) = case pos of- Nothing -> ""- Just p -> style Faint $ "at src:" <> build p+ 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)+ { 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 stock (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)+ = HeaderAnchor Int+ -- ^ Every section header is usually an anchor+ | HandAnchor+ -- ^ They can be set up manually+ | BiblioAnchor+ -- ^ Id of entry in bibliography+ deriving stock (Show, Eq, Generic) -- | A referable anchor. data Anchor = Anchor- { aType :: AnchorType- , aName :: Text- , aPos :: Position- } deriving (Show, Generic)+ { aType :: AnchorType+ , aName :: Text+ , aPos :: Position+ } deriving stock (Show, Eq, Generic) +data FileInfoDiff = FileInfoDiff+ { _fidReferences :: DList Reference+ , _fidAnchors :: DList Anchor+ }+makeLenses ''FileInfoDiff++diffToFileInfo :: FileInfoDiff -> FileInfo+diffToFileInfo (FileInfoDiff refs anchors) =+ FileInfo (DList.toList refs) (DList.toList anchors)++instance Semigroup FileInfoDiff where+ FileInfoDiff a b <> FileInfoDiff c d = FileInfoDiff (a <> c) (b <> d)++instance Monoid FileInfoDiff where+ mempty = FileInfoDiff mempty mempty+ -- | All information regarding a single file we care about. data FileInfo = FileInfo- { _fiReferences :: [Reference]- , _fiAnchors :: [Anchor]- } deriving (Show, Generic)+ { _fiReferences :: [Reference]+ , _fiAnchors :: [Anchor]+ } deriving stock (Show, Generic) makeLenses ''FileInfo instance Default FileInfo where- def = FileInfo [] []+ def = diffToFileInfo mempty newtype RepoInfo = RepoInfo (Map FilePath FileInfo)- deriving (Show)--finaliseFileInfo :: FileInfo -> FileInfo-finaliseFileInfo = execState $ do- fiReferences %= reverse- fiAnchors %= reverse+ deriving stock (Show) ----------------------------------------------------------- -- Instances@@ -121,41 +137,39 @@ 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+ 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"+ 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 |+ ""+ build (Anchor t a p) = a |+ " (" +| t |+ ") " +| p |+ "" instance Buildable FileInfo where- build FileInfo{..} =- blockListF- [ nameF "references" $ blockListF _fiReferences- , nameF "anchors" $ blockListF _fiAnchors- ]+ 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"- ]+ build (RepoInfo m) = blockListF' "⮚" buildFileReport (M.toList m)+ where+ buildFileReport (name, info) = mconcat+ [ color Cyan $ fromString name <> ":\n"+ , build info+ , "\n"+ ] ----------------------------------------------------------- -- Analysing@@ -166,87 +180,87 @@ -- | 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)+ = 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 stock (Eq, Show) instance Buildable LocationType where- build = \case- LocalLoc -> color Green "local"- RelativeLoc -> color Yellow "relative"- AbsoluteLoc -> color Blue "absolute"- ExternalLoc -> color Red "external"- OtherLoc -> ""+ 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+ 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+ 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+ [] -> 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+ = LocalOnlyMode+ | ExternalOnlyMode+ | FullMode shouldCheckLocal :: VerifyMode -> Bool shouldCheckLocal = \case- LocalOnlyMode -> True- ExternalOnlyMode -> False- FullMode -> True+ LocalOnlyMode -> True+ ExternalOnlyMode -> False+ FullMode -> True shouldCheckExternal :: VerifyMode -> Bool shouldCheckExternal = \case- LocalOnlyMode -> False- ExternalOnlyMode -> True- FullMode -> True+ 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 :: Flavor -> Text -> Text headerToAnchor flavor = \t -> t- & T.toLower- & mergeSpecialSymbols+ & T.toLower+ & mergeSpecialSymbols where joinSubsequentChars sym = toText . go . toString where- go = \case- (c1 : c2 : s)- | c1 == c2 && c1 == sym -> go (c1 : s)- (c : s) -> c : go s- [] -> []+ go = \case+ (c1 : c2 : s)+ | c1 == c2 && c1 == sym -> go (c1 : s)+ (c : s) -> c : go s+ [] -> [] mergeSpecialSymbols = case flavor of GitLab -> \t -> t@@ -272,16 +286,14 @@ -- 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+ 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+ maybe ref canonizeLocalRef (T.stripPrefix localPrefix ref) where localPrefix = toText ['.', pathSeparator] @@ -290,29 +302,28 @@ ----------------------------------------------------------- data VerifyProgress = VerifyProgress- { vrLocal :: !(Progress Int)- , vrExternal :: !(Progress Int)- } deriving (Show)+ { vrLocal :: !(Progress Int)+ , vrExternal :: !(Progress Int)+ } deriving stock (Show) initVerifyProgress :: [Reference] -> VerifyProgress-initVerifyProgress references =- VerifyProgress- { vrLocal = initProgress (length localRefs)- , vrExternal = initProgress (length extRefs)- }+initVerifyProgress references = VerifyProgress+ { vrLocal = initProgress (length localRefs)+ , vrExternal = initProgress (length (L.nubBy ((==) `on` rLink) extRefs))+ } where- (extRefs, localRefs) =- L.partition isExternal $- map (locationType . rLink) references+ (extRefs, localRefs) = L.partition (isExternal . locationType . rLink) references -showAnalyseProgress :: VerifyMode -> VerifyProgress -> Text-showAnalyseProgress mode VerifyProgress{..} = mconcat . mconcat $+showAnalyseProgress :: VerifyMode -> Time Second -> VerifyProgress -> Text+showAnalyseProgress mode posixTime VerifyProgress{..} =+ mconcat . mconcat $ [ [ "Verifying " ]- , [ showProgress "local" 10 White vrLocal <> " "+ , [ showProgress "local" 10 White posixTime vrLocal <> " " | shouldCheckLocal mode ]- , [ showProgress "external" 15 Yellow vrExternal+ , [ showProgress "external" 15 Yellow posixTime vrExternal | shouldCheckExternal mode ] ] -reprintAnalyseProgress :: Rewrite -> VerifyMode -> VerifyProgress -> IO ()-reprintAnalyseProgress rw mode p = putTextRewrite rw (showAnalyseProgress mode p)+reprintAnalyseProgress :: Rewrite -> VerifyMode -> Time Second -> VerifyProgress -> IO ()+reprintAnalyseProgress rw mode posixTime p = putTextRewrite rw $+ showAnalyseProgress mode posixTime p
+ src/Xrefcheck/Orphans.hs view
@@ -0,0 +1,65 @@+{- SPDX-FileCopyrightText: 2021 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Orphan instances for types from other packages++module Xrefcheck.Orphans () where++import Universum++import qualified Data.ByteString.Char8 as C++import Fmt (Buildable (..), unlinesF, (+|), (|+))+import Network.FTP.Client+ (FTPException (..), FTPMessage (..), FTPResponse (..), ResponseStatus (..))+import Text.URI (RText, unRText)+import URI.ByteString (URIParseError (..), SchemaError (..))++instance ToString (RText t) where+ toString = toString . unRText++instance Buildable ResponseStatus where+ build = show++instance Buildable FTPMessage where+ build message = build $ decodeUtf8 @Text (+ case message of+ SingleLine s -> s+ MultiLine ss -> C.intercalate "\n" ss+ )++instance Buildable FTPResponse where+ build FTPResponse{..} = unlinesF+ [ frStatus |+ " (" +| frCode |+ "):"+ , build frMessage+ ]++instance Buildable FTPException where+ build (BadProtocolResponseException _) = "Raw FTP exception"+ build (FailureRetryException e) = build e+ build (FailureException e) = build e+ build (UnsuccessfulException e) = build e+ build (BogusResponseFormatException e) = build e++deriving stock instance Eq FTPException++instance Buildable URIParseError where+ build = \case+ MalformedScheme e -> build e+ MalformedUserInfo -> "Malformed user info"+ MalformedQuery -> "Malformed query"+ MalformedFragment -> "Malformed fragment"+ MalformedHost -> "Malformed host"+ MalformedPort -> "Malformed port"+ MalformedPath -> "Malformed path"+ OtherError e -> build e++instance Buildable SchemaError where+ build = \case+ NonAlphaLeading -> "Scheme must start with an alphabet character"+ InvalidChars -> "Subsequent characters in the schema were invalid"+ MissingColon -> "Schemas must be followed by a colon"
src/Xrefcheck/Progress.hs view
@@ -5,82 +5,203 @@ -- | Printing progress bars. module Xrefcheck.Progress- ( -- * Progress- Progress (..)- , initProgress- , incProgress- , incProgressErrors- , showProgress+ ( -- * Task timestamp+ TaskTimestamp (..) - -- * Printing- , Rewrite- , allowRewrite- , putTextRewrite- ) where+ -- * Progress+ , Progress (..)+ , initProgress+ , incProgress+ , incProgressUnfixableErrors+ , incProgressFixableErrors+ , decProgressFixableErrors+ , fixableToUnfixable+ , setTaskTimestamp+ , removeTaskTimestamp+ , checkTaskTimestamp+ , showProgress + -- * Printing+ , Rewrite+ , allowRewrite+ , putTextRewrite+ ) where++import Universum+ import Data.Ratio ((%)) import System.Console.Pretty (Color (..), Style (..), color, style)-import Time (ms, threadDelay)+import Time (Second, Time, ms, sec, threadDelay, unTime, (-:-)) -----------------------------------------------------------+-- Task timestamp+-----------------------------------------------------------++-- | Data type defining a point in time when an anonymous task had started+-- and its time to completion.+data TaskTimestamp = TaskTimestamp+ { ttTimeToCompletion :: Time Second+ -- ^ The amount of time required for the task to be completed.+ , ttStart :: Time Second+ -- ^ The timestamp of when the task had started, represented by the number of seconds+ -- since the Unix epoch.+ } deriving stock (Show)++----------------------------------------------------------- -- 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)+ { 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+ -- ^ 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, pErrors = 0 }+initProgress a = Progress{ pTotal = a+ , pCurrent = 0+ , pErrorsUnfixable = 0+ , pErrorsFixable = 0+ , pTaskTimestamp = Nothing+ } -- | Increase progress amount.-incProgress :: (Num a, Show a) => Progress a -> Progress a+incProgress :: (Num 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, .. }+-- | Increase the number of unfixable errors.+incProgressUnfixableErrors :: (Num a) => Progress a -> Progress a+incProgressUnfixableErrors Progress{..} = Progress{ pErrorsUnfixable = pErrorsUnfixable + 1+ , ..+ } +-- | Increase the number of fixable errors.+incProgressFixableErrors :: (Num a) => Progress a -> Progress a+incProgressFixableErrors Progress{..} = Progress{ pErrorsFixable = pErrorsFixable + 1+ , ..+ }++-- | 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+ , ..+ }++fixableToUnfixable :: (Num a) => Progress a -> Progress a+fixableToUnfixable Progress{..} = Progress{ pErrorsFixable = pErrorsFixable - 1+ , pErrorsUnfixable = pErrorsUnfixable + 1+ , ..+ }++setTaskTimestamp :: Time Second -> Time Second -> Progress a -> Progress a+setTaskTimestamp ttc startTime Progress{..} = Progress{ pTaskTimestamp =+ Just $ TaskTimestamp ttc startTime+ , ..+ }++removeTaskTimestamp :: Progress a -> Progress a+removeTaskTimestamp Progress{..} = Progress{ pTaskTimestamp = Nothing+ , ..+ }++checkTaskTimestamp :: Time Second -> Progress a -> Progress a+checkTaskTimestamp posixTime p@Progress{..} =+ case pTaskTimestamp of+ Nothing -> p+ Just TaskTimestamp{..} ->+ if ttTimeToCompletion >= posixTime -:- ttStart+ then p+ else removeTaskTimestamp p+ -- | Visualise progress bar.-showProgress :: Text -> Int -> Color -> Progress Int -> Text-showProgress name width col Progress{..} = mconcat- [ color col (name <> ": [")- , toText bar- , color col "]"- , status- ]+showProgress :: Text -> Int -> Color -> Time Second -> Progress Int -> Text+showProgress name width col posixTime Progress{..} = mconcat+ [ color col (name <> ": [")+ , toText bar+ , timer+ , 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 "!"+ -- | 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 + -- | The current number of the invalid references.+ errsU = ceiling $ (pErrorsUnfixable % pTotal) * fromIntegral @Int @(Ratio Int) width++ -- | 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.+ -- This is done to ensure that as soon as at least 1 faulty reference occurs during+ -- the verification, the cell of its respective color is mathematically guaranteed+ -- 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) *+ fromIntegral @Int @(Ratio Int) width++ -- | 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.+ remaining = width - successful - errsU - errsF++ bar+ | pTotal == 0 = replicate width '-'+ | otherwise = mconcat+ [ color Blue $ replicate errsF '■'+ , color Red $ replicate errsU '■'+ , color col $ replicate successful '■'+ , color col $ replicate remaining ' '+ , " "+ ]+ timer = case pTaskTimestamp of+ Nothing -> ""+ Just TaskTimestamp{..} -> mconcat+ [ color col "|"+ , color Blue . show . timeSecondCeiling+ $ ttTimeToCompletion -:- (posixTime -:- ttStart)+ ]+ status = mconcat+ [ if pCurrent == pTotal && pErrorsFixable == 0 && pErrorsUnfixable == 0+ then style Faint $ color White "✓"+ else ""+ , if pErrorsFixable /= 0 then color Blue "!" else ""+ , if pErrorsUnfixable /= 0 then color Red "!" else ""+ ]++ timeSecondCeiling :: Time Second -> Time Second+ timeSecondCeiling = sec . fromInteger . ceiling . unTime+ ----------------------------------------------------------- -- Rewritable output ----------------------------------------------------------- -- | Rewrites state. data RewriteCtx = RewriteCtx- { rMaxPrintedSize :: IORef Int- }+ { 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@@ -94,26 +215,33 @@ -- | Provide context for rewrite operations. allowRewrite :: (MonadIO m, MonadMask m) => Bool -> (Rewrite -> m a) -> m a-allowRewrite enabled action =- bracket prepare erase action+allowRewrite enabled = bracket prepare erase where prepare | enabled = do rMaxPrintedSize <- newIORef 0 return $ Rewrite RewriteCtx{..}- | otherwise =- pure RewriteDisabled+ | 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)+ 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+putTextRewrite (Rewrite RewriteCtx{..}) msg = do+ liftIO $ hPutStr stderr ('\r' : toString msg ++ fill)+ atomicModifyIORef' rMaxPrintedSize $ \maxPrinted ->+ (max maxPrinted (length msg), ())+ where+ -- | 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+ -- untouched, and is most likely going to be either replaced by an adequate+ -- workaround or by another way to form a text representation of a progress and+ -- its respective rewriting logic.+ fill = replicate 9 ' '
src/Xrefcheck/Scan.hs view
@@ -6,44 +6,80 @@ -- | Generalised repo scanner and analyser. module Xrefcheck.Scan- ( TraversalConfig (..)- , Extension- , ScanAction- , FormatsSupport- , RepoInfo (..)+ ( TraversalConfig+ , TraversalConfig' (..)+ , Extension+ , ScanAction+ , FormatsSupport+ , RepoInfo (..)+ , ScanError (..)+ , ScanResult (..) - , gatherRepoInfo- , specificFormatsSupport- ) where+ , normaliseTraversalConfigFilePaths+ , scanRepo+ , specificFormatsSupport+ ) where -import Data.Aeson.TH (deriveFromJSON)-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 (takeDirectory, takeExtension, (</>))+import Universum +import Data.Aeson(FromJSON (..), genericParseJSON)+import Data.Foldable qualified as F+import Data.Map qualified as M+import Fmt (Buildable (..), (+|), (|+), nameF)+import System.Console.Pretty (Pretty(..), Style (..))+import System.Directory (doesDirectoryExist)+import System.Directory.Tree qualified as Tree+import System.FilePath (dropTrailingPathSeparator, takeDirectory, takeExtension, equalFilePath)+ import Xrefcheck.Core import Xrefcheck.Progress-import Xrefcheck.Util (aesonConfigOption)+import Xrefcheck.System (readingSystem, RelGlobPattern, normaliseGlobPattern, matchesGlobPatterns)+import Xrefcheck.Util (aesonConfigOption, normaliseWithNoTrailing, Field) +-- | Type alias for TraversalConfig' with all required fields.+type TraversalConfig = TraversalConfig' Identity+ -- | Config of repositry traversal.-data TraversalConfig = TraversalConfig- { tcIgnored :: [FilePath]- -- ^ Files and folders, files in which we completely ignore.- }+data TraversalConfig' f = TraversalConfig+ { tcIgnored :: Field f [RelGlobPattern]+ -- ^ Files and folders, files in which we completely ignore.+ } deriving stock (Generic) -deriveFromJSON aesonConfigOption ''TraversalConfig+instance FromJSON (TraversalConfig' Maybe) where+ parseJSON = genericParseJSON aesonConfigOption +instance FromJSON (TraversalConfig) where+ parseJSON = genericParseJSON aesonConfigOption++normaliseTraversalConfigFilePaths :: TraversalConfig -> TraversalConfig+normaliseTraversalConfigFilePaths = TraversalConfig . map normaliseGlobPattern . tcIgnored+ -- | File extension, dot included. type Extension = String -- | Way to parse a file.-type ScanAction = FilePath -> IO FileInfo+type ScanAction = FilePath -> IO (FileInfo, [ScanError]) -- | All supported ways to parse a file. type FormatsSupport = Extension -> Maybe ScanAction +data ScanResult = ScanResult+ { srScanErrors :: [ScanError]+ , srRepoInfo :: RepoInfo+ } deriving stock (Show)++data ScanError = ScanError+ { sePosition :: Position+ , seFile :: FilePath+ , seDescription :: Text+ } deriving stock (Show, Eq)++instance Buildable ScanError where+ build ScanError{..} =+ "In file " +| style Faint (style Bold seFile) |+ "\n"+ +| nameF ("scan error " +| sePosition |+ "") mempty |+ "\n⛀ "+ +| seDescription |+ "\n\n\n"+ specificFormatsSupport :: [([Extension], ScanAction)] -> FormatsSupport specificFormatsSupport formats = \ext -> M.lookup ext formatsMap where@@ -53,37 +89,45 @@ , 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)+scanRepo+ :: MonadIO m+ => Rewrite -> FormatsSupport -> TraversalConfig -> FilePath -> m ScanResult+scanRepo rw formatsSupport config root = do+ putTextRewrite rw "Scanning repository..."++ when (not $ isDirectory root) $+ die $ "Repository's root does not seem to be a directory: " <> root++ _ Tree.:/ repoTree <- liftIO $ Tree.readDirectoryWithL processFile root+ let (errs, fileInfos) = gatherScanErrs &&& gatherFileInfos+ $ dropSndMaybes . F.toList+ $ Tree.zipPaths $ location Tree.:/ repoTree+ return . ScanResult errs $ RepoInfo (M.fromList fileInfos) where- rootNE = if null root then "." else root- dirOfRoot = if root == "" || root == "." then "" else takeDirectory root+ isDirectory = readingSystem . doesDirectoryExist+ gatherScanErrs = foldMap (snd . snd)+ gatherFileInfos = map (bimap normaliseWithNoTrailing fst)+ processFile file = do- let ext = takeExtension file- let mscanner = formatsSupport ext- forM mscanner $ \scanFile ->- scanFile file+ let ext = takeExtension file+ let mscanner = formatsSupport ext+ if isIgnored file+ then pure Nothing+ else forM mscanner ($ file) dropSndMaybes l = [(a, b) | (a, Just b) <- l] - ignored = map (root </>) (tcIgnored config)- isIgnored path = path `elem` 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+ isIgnored = matchesGlobPatterns root $ tcIgnored config++ -- The context location of the root.+ -- This is done by removing the last component from the path.+ -- > root = "./folder/file.md" ==> location = "./folder"+ -- > root = "./folder/subfolder" ==> location = "./folder"+ -- > root = "./folder/subfolder/" ==> location = "./folder"+ -- > root = "./folder/subfolder/./" ==> location = "./folder/subfolder"+ -- > root = "." ==> location = ""+ -- > root = "/absolute/path" ==> location = "/absolute"+ -- > root = "/" ==> location = "/"+ location =+ if root `equalFilePath` "."+ then ""+ else takeDirectory $ dropTrailingPathSeparator root
src/Xrefcheck/Scanners/Markdown.hs view
@@ -8,255 +8,359 @@ -- | Markdown documents markdownScanner. module Xrefcheck.Scanners.Markdown- ( MarkdownConfig (..)- , defGithubMdConfig- , markdownScanner- , markdownSupport- , parseFileInfo- ) where+ ( MarkdownConfig' (..)+ , MarkdownConfig+ , IgnoreMode (..)+ , defGithubMdConfig+ , markdownScanner+ , markdownSupport+ , parseFileInfo+ , makeError+ ) where +import Universum+ import CMarkGFM (Node (..), NodeType (..), PosInfo (..), commonmarkToNode)-import Control.Lens ((%=))-import Control.Monad.Trans.Except (Except, runExcept, throwE)-import Data.Aeson.TH (deriveFromJSON)-import qualified Data.ByteString.Lazy as BSL-import Data.Char (isSpace)-import Data.Default (Default (..))-import qualified Data.Text as T-import qualified Data.Text.Lazy as LT+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.Text qualified as T+import Data.Text.Lazy qualified as LT import Fmt (Buildable (..), blockListF, nameF, (+|), (|+))+import Text.HTML.TagSoup import Xrefcheck.Core import Xrefcheck.Scan import Xrefcheck.Util -data MarkdownConfig = MarkdownConfig- { mcFlavor :: Flavor- }+-- | Type alias for MarkdownConfig' with all required fields.+type MarkdownConfig = MarkdownConfig' Identity -deriveFromJSON aesonConfigOption ''MarkdownConfig+data MarkdownConfig' f = MarkdownConfig+ { mcFlavor :: Field f Flavor+ } deriving stock (Generic) +instance FromJSON (MarkdownConfig' Maybe) where+ parseJSON = genericParseJSON aesonConfigOption++instance FromJSON (MarkdownConfig) where+ parseJSON = genericParseJSON aesonConfigOption+ defGithubMdConfig :: MarkdownConfig defGithubMdConfig = MarkdownConfig { mcFlavor = GitHub } instance Buildable Node where- build (Node _mpos ty subs) = nameF (show ty) $ blockListF subs+ 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+ Nothing -> Nothing+ Just PosInfo{..}+ | startLine == endLine -> Just $+ startLine |+ ":" +| startColumn |+ "-" +| endColumn |+ ""+ | otherwise -> Just $+ "" +|+ startLine |+ ":" +| startColumn |+ " - " +|+ endLine |+ ":" +| endColumn |+ "" +-- | Extract text from the topmost node. nodeExtractText :: Node -> Text-nodeExtractText = mconcat . map extractText . nodeFlatten+nodeExtractText = T.strip . mconcat . map extractText . nodeFlatten where extractText = \case- TEXT t -> t- CODE t -> t- _ -> ""+ TEXT t -> t+ CODE t -> t+ _ -> "" + nodeFlatten :: Node -> [NodeType]+ nodeFlatten (Node _pos ty subs) = ty : concatMap nodeFlatten subs+ data IgnoreMode- = Link- | Paragraph- | File- deriving Eq+ = Link+ | Paragraph+ | File+ | None+ deriving stock (Eq) -nodeExtractInfo :: MarkdownConfig -> Node -> Except Text FileInfo-nodeExtractInfo config (Node _ _ docNodes) =- if checkIgnoreFile docNodes- then return def- else finaliseFileInfo <$> extractionResult- where- extractionResult :: Except Text FileInfo- extractionResult =- execStateT (loop docNodes Nothing) def+-- | Bind `IgnoreMode` to its `PosInfo` so that we can tell where the+-- corresponding annotation was declared.+data Ignore = Ignore IgnoreMode (Maybe PosInfo) - loop :: [Node] -> Maybe IgnoreMode -> StateT FileInfo (Except Text) ()- loop [] _ = pass- loop (node@(Node pos ty subs) : nodes) toIgnore- | toIgnore == Just File = returnError toIgnore "" pos- | toIgnore == Just Link = do- let (Node startPos _ _) = maybe defNode id $ safeHead subs- let mNext = case ty of- PARAGRAPH -> afterIgnoredLink subs <> Just nodes- TEXT txt | null (dropWhile isSpace $ T.unpack txt) -> afterIgnoredLink nodes- SOFTBREAK -> afterIgnoredLink nodes- _ -> afterIgnoredLink (node : nodes)- case mNext of- Just next -> loop next Nothing- Nothing -> returnError toIgnore "" startPos- | toIgnore == Just Paragraph =- case ty of- PARAGRAPH -> loop nodes Nothing- _ -> returnError toIgnore (prettyType ty) pos- | otherwise =- case ty of- HTML_BLOCK _ -> processHtmlNode node pos nodes toIgnore- HEADING lvl -> do- let aType = HeaderAnchor lvl- let aName = headerToAnchor (mcFlavor config) $- nodeExtractText node- let aPos = toPosition pos- fiAnchors %= (Anchor{..} :)- loop nodes toIgnore- 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{..} :)- processHtmlNode node pos nodes toIgnore- 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{..} :)- loop nodes toIgnore- _ -> loop (subs ++ nodes) toIgnore+type ScannerM a = StateT Ignore (Writer [ScanError]) a - defNode :: Node- defNode = Node Nothing DOCUMENT [] -- hard-coded default Node+-- | Empty `Ignore` state+ignoreNone :: Ignore+ignoreNone = Ignore None Nothing - getCommentContent :: Node -> Maybe Text- getCommentContent node = do- txt <- getHTMLText node- T.stripSuffix "-->" =<< T.stripPrefix "<!--" (T.strip txt)- where- getHTMLText :: Node -> Maybe Text- getHTMLText (Node _ (HTML_BLOCK txt) _) = Just txt- getHTMLText (Node _ (HTML_INLINE txt) _) = Just txt- getHTMLText _ = Nothing+-- | A fold over a `Node`.+cataNode :: (Maybe PosInfo -> NodeType -> [c] -> c) -> Node -> c+cataNode f (Node pos ty subs) = f pos ty (cataNode f <$> subs) - getXrefcheckContent :: Node -> Maybe Text- getXrefcheckContent node =- let notStripped = T.stripPrefix "xrefcheck:" . T.strip =<<- getCommentContent node- in T.strip <$> notStripped+-- | Remove nodes with accordance with global `MarkdownConfig` and local+-- overrides.+removeIgnored :: FilePath -> Node -> Writer [ScanError] Node+removeIgnored fp = withIgnoreMode . cataNode remove+ where+ remove+ :: Maybe PosInfo+ -> NodeType+ -> [ScannerM Node]+ -> ScannerM Node+ remove pos ty subs = do+ Ignore mode modePos <- get+ let node = Node pos ty []+ 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.+ (Paragraph, PARAGRAPH) -> put ignoreNone $> defNode+ (Paragraph, x) -> do+ lift . tell . makeError modePos fp mode $ prettyType x+ put ignoreNone+ Node pos ty <$> sequence subs - getIgnoreMode :: Node -> Maybe IgnoreMode- getIgnoreMode node =- let mContent = getXrefcheckContent node+ -- We don't expect to find an `ignore file` 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.+ (File, _) -> do+ lift . tell $ makeError modePos fp mode ""+ put ignoreNone+ Node pos ty <$> sequence subs - textToMode :: [Text] -> Maybe IgnoreMode- textToMode ("ignore" : [x])- | x == "link" = return Link- | x == "paragraph" = return Paragraph- | x == "file" = return File- | otherwise = Nothing- textToMode _ = Nothing- in textToMode . words =<< mContent+ -- When we find an `ignore link` annotation, we skip nodes until+ -- we find a link and ignore it, or we find another ignore annotation,+ -- then we should report an error and set new `Ignore` state.+ (Link, LINK {}) -> put ignoreNone $> defNode+ (Link, _) ->+ case getIgnoreMode node of+ Just mode' -> do+ lift . tell $ makeError modePos fp mode ""+ handleMode node mode'+ Nothing -> Node pos ty <$> sequence subs - isComment :: Node -> Bool- isComment = isJust . getCommentContent+ -- When no `Ignore` state is set check next node for annotation,+ -- if found then set it as new `IgnoreMode` otherwise skip node.+ (None, _) ->+ case getIgnoreMode node of+ Just mode' -> handleMode node mode'+ Nothing -> Node pos ty <$> sequence subs - isIgnoreFile :: Node -> Bool- isIgnoreFile = (Just File ==) . getIgnoreMode+ handleMode+ :: Node+ -> IgnoreMode+ -> ScannerM Node+ handleMode node = \case+ -- Report unknown `IgnoreMode`.+ None -> do+ let unrecognised = fromMaybe ""+ $ safeHead . drop 1 . words =<< getXrefcheckContent node+ lift . tell $ makeError (getPosition node) fp None unrecognised+ put ignoreNone $> defNode+ -- Set new `Ignore` state.+ mode' -> put (Ignore mode' $ getPosition node) $> defNode - checkIgnoreFile :: [Node] -> Bool- checkIgnoreFile nodes =- let isSimpleComment :: Node -> Bool- isSimpleComment node = isComment node && not (isIgnoreFile node)+ prettyType :: NodeType -> Text+ prettyType ty =+ let mType = safeHead $ words $ show ty+ in fromMaybe "" mType - mIgnoreFile = safeHead $ dropWhile isSimpleComment nodes- in maybe False isIgnoreFile mIgnoreFile+ withIgnoreMode+ :: ScannerM Node+ -> Writer [ScanError] Node+ withIgnoreMode action = action `runStateT` ignoreNone >>= \case+ -- We expect `IgnoreMode` to be `None` when we reach EOF,+ -- otherwise that means there was an annotation that didn't match+ -- any node, so we have to report that.+ (node, Ignore None _) -> pure node+ (node, (Ignore mode pos))+ | mode == Paragraph -> do+ tell $ makeError pos fp mode "EOF"+ pure node+ -- Link and File scan errors do not require extra text info+ -- to make error description.+ | otherwise -> do+ tell $ makeError pos fp mode ""+ pure node - isLink :: Node -> Bool- isLink (Node _ (LINK _ _) _) = True- isLink _ = False - isText :: Node -> Bool- isText (Node _ (TEXT _) _) = True- isText _ = False+-- | Custom `foldMap` for source tree.+foldNode :: (Monoid a, Monad m) => (Node -> m a) -> Node -> m a+foldNode action node@(Node _ _ subs) = do+ a <- action node+ b <- concatForM subs (foldNode action)+ return (a <> b) - afterIgnoredLink :: [Node] -> Maybe [Node]- afterIgnoredLink (fNode : nodes)- | isLink fNode = return nodes- | sNode : nodes' <- nodes =- if isText fNode && isLink sNode- then return nodes'- else Nothing- | otherwise = Nothing- afterIgnoredLink _ = Nothing+type ExtractorM a = ReaderT MarkdownConfig (Writer [ScanError]) a - prettyPos :: Maybe PosInfo -> Text- prettyPos pos =- let posToText :: Position -> Text- posToText (Position mPos) = fromMaybe "" mPos- in "(" <> (posToText $ toPosition pos) <> ")"+-- | 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)) - prettyType :: NodeType -> Text- prettyType ty =- let mType = safeHead $ words $ show ty- in maybe "" id mType+ where+ extractor :: Node -> ExtractorM FileInfoDiff+ extractor node@(Node pos ty _) =+ case ty of+ HTML_BLOCK _ -> do+ return mempty - fileMsg :: Text- fileMsg =- "\"ignore file\" must be at the top of \- \markdown or right after comments at the top"+ HEADING lvl -> do+ flavor <- asks mcFlavor+ let aType = HeaderAnchor lvl+ let aName = headerToAnchor flavor $ nodeExtractText node+ let aPos = toPosition pos+ return $ FileInfoDiff DList.empty $ DList.singleton $ Anchor {aType, aName, aPos} - linkMsg :: Text- linkMsg = "expected a LINK after \"ignore link\" "+ HTML_INLINE text -> do+ let+ mName = do+ tag <- safeHead $ parseTags text+ attributes <- case tag of+ TagOpen a attrs+ | T.toLower a == "a" -> Just attrs+ _ -> Nothing+ (_, name) <- find (\(field, _) -> T.toLower field `elem` ["name", "id"]) attributes+ pure name - paragraphMsg :: Text -> Text- paragraphMsg txt = unwords- [ "expected a PARAGRAPH after \- \\"ignore paragraph\", but found"- , txt- , ""- ]+ case mName of+ Just aName -> do+ let aType = HandAnchor+ aPos = toPosition pos+ return $ FileInfoDiff+ mempty+ (pure $ Anchor {aType, aName, aPos}) - unrecognisedMsg :: Text -> Text- unrecognisedMsg txt = unwords- [ "unrecognised option"- , "\"" <> txt <> "\""- , "perhaps you meant \- \<\"ignore link\"|\"ignore paragraph\"|\"ignore file\"> "- ]+ Nothing -> do+ return mempty - returnError :: Maybe IgnoreMode -> Text -> Maybe PosInfo -> StateT FileInfo (Except Text) ()- returnError mode txt pos =- let errMsg = case mode of- Just Link -> linkMsg- Just Paragraph -> paragraphMsg txt- Just File -> fileMsg- Nothing -> unrecognisedMsg txt- posInfo = prettyPos pos- in lift $ throwE $ errMsg <> posInfo+ 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"+ return $ FileInfoDiff+ (DList.singleton $ Reference {rName, rPos, rLink, rAnchor})+ DList.empty - processHtmlNode :: Node -> Maybe PosInfo -> [Node] -> Maybe IgnoreMode -> StateT FileInfo (Except Text) ()- processHtmlNode node pos nodes toIgnore = do- let xrefcheckContent = getXrefcheckContent node- case xrefcheckContent of- Just content -> maybe (returnError Nothing content pos)- (loop nodes . pure) $ getIgnoreMode node- Nothing -> loop nodes toIgnore+ _ -> return mempty -parseFileInfo :: MarkdownConfig -> LT.Text -> Either Text FileInfo-parseFileInfo config input = runExcept $ nodeExtractInfo config $- commonmarkToNode [] [] $ toStrict input+-- | Check if there is `ignore file` at the beginning of the file,+-- ignoring preceding comments if there are any.+checkIgnoreFile :: [Node] -> Bool+checkIgnoreFile nodes =+ let isSimpleComment :: Node -> Bool+ isSimpleComment node = isComment node && not (isIgnoreFile node) + mIgnoreFile = safeHead $ dropWhile isSimpleComment nodes+ in maybe False isIgnoreFile mIgnoreFile+ where+ isComment :: Node -> Bool+ isComment = isJust . getCommentContent++ isIgnoreFile :: Node -> Bool+ isIgnoreFile = (Just File ==) . getIgnoreMode++defNode :: Node+defNode = Node Nothing DOCUMENT [] -- hard-coded default Node++makeError+ :: Maybe PosInfo+ -> FilePath+ -> IgnoreMode+ -> Text+ -> [ScanError]+makeError pos fp mode txt = one . ScanError (toPosition pos) fp $ case mode of+ Link -> linkMsg+ Paragraph -> paragraphMsg+ File -> fileMsg+ None -> unrecognisedMsg+ where+ fileMsg :: Text+ fileMsg =+ "Annotation \"ignore file\" must be at the top of \+ \markdown or right after comments at the top"++ linkMsg :: Text+ linkMsg = "Expected a LINK after \"ignore link\" annotation"++ paragraphMsg :: Text+ paragraphMsg = unwords+ [ "Expected a PARAGRAPH after \+ \\"ignore paragraph\" annotation, but found"+ , txt+ ]++ unrecognisedMsg :: Text+ unrecognisedMsg = unwords+ [ "Unrecognised option"+ , "\"" <> txt <> "\""+ , "perhaps you meant \+ \<\"ignore link\"|\"ignore paragraph\"|\"ignore file\"> "+ ]++getCommentContent :: Node -> Maybe Text+getCommentContent node = do+ txt <- getHTMLText node+ T.stripSuffix "-->" =<< T.stripPrefix "<!--" (T.strip txt)++getHTMLText :: Node -> Maybe Text+getHTMLText (Node _ (HTML_BLOCK txt) _) = Just txt+getHTMLText (Node _ (HTML_INLINE txt) _) = Just txt+getHTMLText _ = Nothing++getXrefcheckContent :: Node -> Maybe Text+getXrefcheckContent node =+ let notStripped = T.stripPrefix "xrefcheck:" . T.strip =<<+ getCommentContent node+ in T.strip <$> notStripped++-- | Get the correct position of an annotation node. There is a bug in+-- `commonmarkToNode` from the `cmark-gfm` package that affects one line+-- `HTML_BLOCK` nodes, those node have wrong end line and end column positions.+-- As our annotations are always oneliners, we can fix this by simply setting+-- end line equals to start line and calculating end column from start column+-- and annotation length.+getPosition :: Node -> Maybe PosInfo+getPosition node@(Node pos _ _) = do+ annLength <- length . T.strip <$> getHTMLText node+ PosInfo sl sc _ _ <- pos+ pure $ PosInfo sl sc sl (sc + annLength - 1)++-- | Extract `IgnoreMode` if current node is xrefcheck annotation.+getIgnoreMode :: Node -> Maybe IgnoreMode+getIgnoreMode node = textToMode . words =<< getXrefcheckContent node++textToMode :: [Text] -> Maybe IgnoreMode+textToMode ("ignore" : [x])+ | x == "link" = return Link+ | x == "paragraph" = return Paragraph+ | x == "file" = return File+ | otherwise = return None+textToMode _ = Nothing++parseFileInfo :: MarkdownConfig -> FilePath -> LT.Text -> (FileInfo, [ScanError])+parseFileInfo config fp input+ = runWriter+ $ flip runReaderT config+ $ nodeExtractInfo fp+ $ commonmarkToNode [] []+ $ toStrict input+ markdownScanner :: MarkdownConfig -> ScanAction-markdownScanner config path = do- errOrInfo <- parseFileInfo config . decodeUtf8 <$> BSL.readFile path- case errOrInfo of- Left errTxt -> do- die $ "Error when scanning " <> path <> ": " <> T.unpack errTxt- Right fileInfo -> return fileInfo+markdownScanner config path = parseFileInfo config path . decodeUtf8 <$> BSL.readFile path markdownSupport :: MarkdownConfig -> ([Extension], ScanAction) markdownSupport config = ([".md"], markdownScanner config)
src/Xrefcheck/System.hs view
@@ -4,19 +4,25 @@ -} module Xrefcheck.System- ( readingSystem- , askWithinCI- , RelGlobPattern (..)- , bindGlobPattern- ) where+ ( readingSystem+ , askWithinCI+ , RelGlobPattern (..)+ , normaliseGlobPattern+ , bindGlobPattern+ , matchesGlobPatterns+ ) where +import Universum+ import Data.Aeson (FromJSON (..), withText)-import qualified Data.Char as C+import Data.Char qualified as C import GHC.IO.Unsafe (unsafePerformIO) import System.Directory (canonicalizePath) import System.Environment (lookupEnv) import System.FilePath ((</>))-import qualified System.FilePath.Glob as Glob+import System.FilePath.Glob qualified as Glob+import Data.Coerce (coerce)+import Xrefcheck.Util (normaliseWithNoTrailing) -- | We can quite safely treat surrounding filesystem as frozen, -- so IO reading operations can be turned into pure values.@@ -34,24 +40,34 @@ -- | Glob pattern relative to repository root. newtype RelGlobPattern = RelGlobPattern FilePath +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+ Left err -> error $+ "Glob pattern compilation failed after canonicalization: " <> toText err Right pat -> return pat +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+ ]+ instance FromJSON RelGlobPattern where- parseJSON = withText "Repo-relative glob pattern" $ \path -> do- let spath = toString path- -- Checking path is sane- _ <- Glob.tryCompileWith globCompileOptions spath- & either fail pure- return (RelGlobPattern spath)+ parseJSON = withText "Repo-relative glob pattern" $ \path -> do+ let spath = toString path+ -- Checking path is sane+ _ <- Glob.tryCompileWith globCompileOptions spath+ & either fail pure+ return (RelGlobPattern spath) -- | Glob compilation options we use. globCompileOptions :: Glob.CompOptions
src/Xrefcheck/Util.hs view
@@ -6,30 +6,43 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Xrefcheck.Util- ( nameF'- , paren- , postfixFields- , (-:)- , aesonConfigOption- ) where+ ( Field+ , nameF'+ , paren+ , postfixFields+ , (-:)+ , aesonConfigOption+ , normaliseWithNoTrailing+ , posixTimeToTimeSecond+ , utcTimeToTimeSecond+ ) where +import Universum+ import Control.Lens (LensRules, lensField, lensRules, mappingNamer)-import qualified Data.Aeson as Aeson+import Data.Aeson qualified as Aeson import Data.Aeson.Casing (aesonPrefix, camelCase)+import Data.Fixed (Fixed (MkFixed), HasResolution (resolution))+import Data.Ratio ((%))+import Data.Time (UTCTime)+import Data.Time.Clock (nominalDiffTimeToSeconds)+import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds) import Fmt (Builder, build, fmt, nameF) import System.Console.Pretty (Pretty (..), Style (Faint))+import System.FilePath (dropTrailingPathSeparator, normalise)+import Time (Second, Time (..), sec) 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+nameF' a = nameF (style Faint a) paren :: Builder -> Builder paren a- | a == "" = ""- | otherwise = "(" <> a <> ")"+ | a == "" = ""+ | otherwise = "(" <> a <> ")" postfixFields :: LensRules postfixFields = lensRules & lensField .~ mappingNamer (\n -> [n ++ "L"])@@ -41,3 +54,19 @@ -- | Options that we use to derive JSON instances for config types. aesonConfigOption :: Aeson.Options aesonConfigOption = aesonPrefix camelCase++-- | Config fields that may be abscent.+type family Field f a where+ 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+ in sec . fromRational $ ps % resolution picos++utcTimeToTimeSecond :: UTCTime -> Time Second+utcTimeToTimeSecond = posixTimeToTimeSecond . utcTimeToPOSIXSeconds
src/Xrefcheck/Verify.hs view
@@ -1,4 +1,4 @@-{- SPDX-FileCopyrightText: 2018-2019 Serokell <https://serokell.io>+{- SPDX-FileCopyrightText: 2018-2021 Serokell <https://serokell.io> - - SPDX-License-Identifier: MPL-2.0 -}@@ -8,43 +8,70 @@ {-# OPTIONS_GHC -Wno-partial-type-signatures #-} module Xrefcheck.Verify- ( -- * General verification- VerifyResult (..)- , verifyOk- , verifyErrors- , verifying+ ( -- * General verification+ VerifyResult (..)+ , verifyOk+ , verifyErrors+ , verifying - , WithReferenceLoc (..)+ , RetryAfter (..)+ , WithReferenceLoc (..) - -- * Cross-references validation- , VerifyError (..)- , verifyRepo- , checkExternalResource- ) where+ -- * Concurrent traversal with caching+ , NeedsCaching (..)+ , forConcurrentlyCaching -import Control.Concurrent.Async (forConcurrently, withAsync)+ -- * Cross-references validation+ , VerifyError (..)+ , verifyRepo+ , verifyReference+ , checkExternalResource++ -- * URI parsing+ , parseUri+ ) where++import Universum++import Control.Concurrent.Async (wait, withAsync)+import Control.Exception (throwIO) import Control.Monad.Except (MonadError (..))-import qualified Data.Map as M-import qualified Data.Text as T+import Data.ByteString qualified as BS+import Data.List qualified as L+import Data.Map qualified as M 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, req, runReq, useURI)+import Data.Time (UTCTime, defaultTimeLocale, formatTime, readPTime, rfc822DateFormat)+import Data.Time.Clock.POSIX (getPOSIXTime)+import Data.Traversable (for)+import Fmt (Buildable (..), blockListF', listF, maybeF, nameF, (+|), (|+), unlinesF, indentF)+import GHC.Exts qualified as Exts+import GHC.Read (Read (readPrec))+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)+import Network.HTTP.Types.Header (hRetryAfter) import Network.HTTP.Types.Status (Status, statusCode, statusMessage) import System.Console.Pretty (Style (..), style)-import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist)-import System.FilePath (takeDirectory, (</>))-import qualified System.FilePath.Glob as Glob+import System.Directory (doesDirectoryExist, doesFileExist)+import System.FilePath (takeDirectory, (</>), normalise)+import Text.ParserCombinators.ReadPrec qualified as ReadPrec (lift) import Text.Regex.TDFA.Text (Regex, regexec)-import Text.URI (mkURI)-import Time (RatioNat, Second, Time (..), ms, threadDelay, timeout)+import Text.URI (Authority (..), URI (..), mkURIBs, ParseExceptionBs)+import Time (RatioNat, Second, Time (..), ms, sec, threadDelay, timeout, (+:+), (-:-))+import URI.ByteString qualified as URIBS+import Control.Monad.Catch (handleJust) +import Data.Bits (toIntegralSized) import Xrefcheck.Config import Xrefcheck.Core+import Xrefcheck.Orphans () import Xrefcheck.Progress import Xrefcheck.System+import Xrefcheck.Util {-# ANN module ("HLint: ignore Use uncurry" :: Text) #-} {-# ANN module ("HLint: ignore Use 'runExceptT' from Universum" :: Text) #-}@@ -54,15 +81,13 @@ ----------------------------------------------------------- newtype VerifyResult e = VerifyResult [e]- deriving (Show, Functor)+ deriving newtype (Show, Eq, Functor) -deriving instance Semigroup (VerifyResult e)-deriving instance Monoid (VerifyResult e)+deriving newtype instance Semigroup (VerifyResult e)+deriving newtype instance Monoid (VerifyResult e) instance Buildable e => Buildable (VerifyResult e) where- build vr = case verifyErrors vr of- Nothing -> "ok"- Just errs -> listF errs+ build vr = maybe "ok" listF (verifyErrors vr) verifyOk :: VerifyResult e -> Bool verifyOk (VerifyResult errors) = null errors@@ -81,230 +106,518 @@ ----------------------------------------------------------- data WithReferenceLoc a = WithReferenceLoc- { wrlFile :: FilePath- , wrlReference :: Reference- , wrlItem :: a- }+ { 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"+ 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- | ExternalResourceUnknownProtocol- | ExternalResourceUnavailable Status- | ExternalResourceSomeError Text- deriving (Show)+ = LocalFileDoesNotExist FilePath+ | AnchorDoesNotExist Text [Anchor]+ | AmbiguousAnchorRef FilePath Text (NonEmpty Anchor)+ | ExternalResourceInvalidUri URIBS.URIParseError+ | ExternalResourceUriConversionError ParseExceptionBs+ | ExternalResourceInvalidUrl (Maybe Text)+ | ExternalResourceUnknownProtocol+ | ExternalHttpResourceUnavailable Status+ | ExternalHttpTooManyRequests (Maybe RetryAfter)+ | ExternalFtpResourceUnavailable FTPResponse+ | ExternalFtpException FTPException+ | FtpEntryDoesNotExist FilePath+ | ExternalResourceSomeError Text+ deriving stock (Show, Eq) 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 ->- "⛂ Invalid url\n"- ExternalResourceUnknownProtocol ->- "⛂ 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+ build = \case+ LocalFileDoesNotExist 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 err ->+ "⛂ Invalid URI (" +| err |+ ")\n"++ ExternalResourceUriConversionError err ->+ unlinesF+ [ "⛂ Invalid URI"+ , indentF 4 . build $ displayException err+ ]++ ExternalResourceInvalidUrl Nothing ->+ "⛂ Invalid URL\n"++ ExternalResourceInvalidUrl (Just message) ->+ "⛂ Invalid URL (" +| message |+ ")\n"++ ExternalResourceUnknownProtocol ->+ "⛂ Bad url (expected 'http','https', 'ftp' or 'ftps')\n"++ ExternalHttpResourceUnavailable status ->+ "⛂ Resource unavailable (" +| statusCode status |+ " " +|+ decodeUtf8 @Text (statusMessage status) |+ ")\n"++ ExternalHttpTooManyRequests retryAfter ->+ "⛂ Resource unavailable (429 Too Many Requests; retry after " +|+ maybeF retryAfter |+ ")\n"++ ExternalFtpResourceUnavailable response ->+ "⛂ Resource unavailable:\n" +| response |+ "\n"++ ExternalFtpException err ->+ "⛂ FTP exception (" +| err |+ ")\n"++ FtpEntryDoesNotExist entry ->+ "⛂ File or directory does not exist:\n" +| entry |+ "\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++data RetryAfter = Date UTCTime | Seconds (Time Second)+ deriving stock (Show, Eq)++instance Read RetryAfter where+ readPrec = asum+ [ ReadPrec.lift $ Date <$> readPTime True defaultTimeLocale rfc822DateFormat+ , readPrec @Natural <&> Seconds . sec . fromIntegral @_ @RatioNat+ ]++instance Buildable RetryAfter where+ build (Date d) = nameF "date" $+ 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++-- | Perform concurrent traversal of the list with the caching mechanism.+-- The function is semantically similar to @Control.Concurrent.Async.forConcurrently@;+-- each asynchronous result of the @action@ is prepended to the accumulator list @[Async b]@.+-- Additionally, these action results may also be inserted in a map of the type+-- @Map cacheKey (Async b)@, depending on the return value of the function+-- @a -> NeedsCaching cacheKey@ applied to each of the element from the given list.+-- If an element of the type @a@ needs caching, and the value is already present in the map,+-- 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.+forConcurrentlyCaching+ :: Ord cacheKey+ => [a] -> (a -> NeedsCaching cacheKey) -> (a -> IO b) -> IO [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+ 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+ 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)+ :: 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 $ matchesGlobPatterns root vcNotScanned file+ ref <- _fiReferences fileInfo+ return (file, ref) - progressRef <- newIORef $ initVerifyProgress (map snd toScan)+ progressRef <- newIORef $ initVerifyProgress (map snd toScan) - withAsync (printer progressRef) $ \_ ->- fmap fold . forConcurrently toScan $ \(file, ref) ->- verifyReference config mode progressRef repoInfo' root file ref+ accumulated <- withAsync (printer progressRef) $ \_ ->+ forConcurrentlyCaching toScan ifExternalThenCache $ \(file, ref) ->+ verifyReference config mode progressRef repoInfo' root file ref+ return $ fold accumulated where printer progressRef = forever $ do- readIORef progressRef >>= reprintAnalyseProgress rw mode- threadDelay (ms 100)+ posixTime <- getPOSIXTime <&> posixTimeToTimeSecond+ progress <- atomicModifyIORef' progressRef $ \VerifyProgress{..} ->+ let prog = VerifyProgress{ vrExternal =+ checkTaskTimestamp posixTime vrExternal+ , ..+ }+ in (prog, prog)+ reprintAnalyseProgress rw mode posixTime progress+ threadDelay (ms 100) + ifExternalThenCache (_, Reference{..}) = case locationType rLink of+ ExternalLoc -> CacheUnderKey rLink+ _ -> NoCaching+ shouldCheckLocType :: VerifyMode -> LocationType -> Bool shouldCheckLocType mode locType- | isExternal locType = shouldCheckExternal mode- | isLocal locType = shouldCheckLocal mode- | otherwise = False+ | 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+ :: VerifyConfig+ -> VerifyMode+ -> IORef VerifyProgress+ -> RepoInfo+ -> FilePath+ -> FilePath+ -> Reference+ -> IO (VerifyResult $ WithReferenceLoc VerifyError)+verifyReference+ config@VerifyConfig{..}+ mode+ progressRef+ (RepoInfo repoInfo)+ root+ fileWithReference+ ref@Reference{..}+ = retryVerification 0 $ do+ let locType = locationType rLink+ if shouldCheckLocType mode locType+ then case locType of+ LocalLoc -> 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+ where+ retryVerification+ :: Int+ -> IO (VerifyResult VerifyError)+ -> IO (VerifyResult $ WithReferenceLoc VerifyError)+ retryVerification numberOfRetries resIO = do+ res@(VerifyResult ves) <- resIO - let locType = locationType rLink+ now <- getPOSIXTime <&> posixTimeToTimeSecond - 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 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 moveProgress =- incProgress .- (if verifyOk res then id else incProgressErrors)+ let toRetry = any isFixable ves && numberOfRetries < vcMaxRetries+ currentRetryAfter = fromMaybe vcDefaultRetryAfter $+ extractRetryAfterInfo res <&> toSeconds - 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+ let moveProgress = alterOverallProgress numberOfRetries+ . alterProgressErrors res numberOfRetries++ 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++ alterOverallProgress+ :: (Num a)+ => Int+ -> Progress a+ -> Progress a+ alterOverallProgress retryNumber+ | retryNumber > 0 = id+ | otherwise = incProgress++ 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+ where+ ok = verifyOk res+ fixable = any isFixable ves++ extractRetryAfterInfo :: VerifyResult VerifyError -> Maybe RetryAfter+ extractRetryAfterInfo = \case+ VerifyResult [ExternalHttpTooManyRequests retryAfter] -> retryAfter+ _ -> Nothing+ 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 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 fileExists = readingSystem $ doesFileExist file+ let dirExists = readingSystem $ doesDirectoryExist file - let cfile = readingSystem $ canonicalizePath file- let isVirtual = or- [ Glob.match pat cfile- | virtualFile <- vcVirtualFiles- , let pat = bindGlobPattern root virtualFile ]+ let isVirtual = matchesGlobPatterns root vcVirtualFiles file - unless (fileExists || dirExists || isVirtual) $- throwError (FileDoesNotExist file)+ unless (fileExists || dirExists || isVirtual) $+ throwError (LocalFileDoesNotExist file) checkAnchor file fileAnchors anchor = do- checkAnchorReferenceAmbiguity file fileAnchors anchor- checkDeduplicatedAnchorReference file fileAnchors anchor- checkAnchorExists fileAnchors anchor+ 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)+ 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+ 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+ 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)+-- | 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- | doesReferLocalhost = return mempty- | otherwise = fmap toVerifyRes $ do- makeRequest HEAD 0.3 >>= \case- Right () -> return $ Right ()- Left _ -> makeRequest GET 0.7+ | isIgnored = return mempty+ | otherwise = fmap toVerifyRes $ runExceptT $ do+ uri <- parseUri link+ case toString <$> uriScheme uri of+ Just "http" -> checkHttp uri+ Just "https" -> checkHttp uri+ Just "ftp" -> checkFtp uri False+ Just "ftps" -> checkFtp uri True+ _ -> throwError ExternalResourceUnknownProtocol where- isIgnored =- let maybeIsIgnored = (doesMatchAnyRegex link) <$> vcIgnoreRefs- in fromMaybe False maybeIsIgnored- doesReferLocalhost = any (`T.isInfixOf` link) ["://localhost", "://127.0.0.1"]+ isIgnored = doesMatchAnyRegex link vcIgnoreRefs 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+ 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 - makeRequest :: _ => method -> RatioNat -> IO (Either VerifyError ())- makeRequest method timeoutFrac = runExceptT $ do- uri <- mkURI link- & maybe (throwError ExternalResourceInvalidUri) pure- parsedUrl <- useURI uri- & maybe (throwError ExternalResourceUnknownProtocol) 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+ checkHttp :: URI -> ExceptT VerifyError IO ()+ checkHttp uri = makeHttpRequest uri HEAD 0.3 `catchError` \case+ e | isFixable e -> throwError e+ _ -> makeHttpRequest uri GET 0.7 - let maxTime = Time @Second $ unTime vcExternalRefCheckTimeout * timeoutFrac+ makeHttpRequest+ :: (HttpMethod method, HttpBodyAllowed (AllowsBody method) 'NoBody)+ => URI+ -> method+ -> RatioNat+ -> ExceptT VerifyError IO ()+ makeHttpRequest uri method timeoutFrac = do+ parsedUrl <- case useURI uri of+ -- accordingly to source code - Nothing can be only in case when+ -- protocol is not http or https, but we've checked it already+ -- 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+ Right (url, option) ->+ runReq defaultHttpConfig $+ req method url NoReqBody ignoreResponse option - mres <- liftIO (timeout maxTime $ void reqLink)- `catch` (either throwError (\() -> return (Just ())) . interpretErrors)- maybe (throwError $ ExternalResourceSomeError "Response timeout") pure mres+ 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- ]+ -- 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+ then flip elem [403, 401]+ else const False+ , (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+ 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 -> case statusCode (responseStatus resp) of+ 429 -> Left . ExternalHttpTooManyRequests $ retryAfterInfo resp+ _ -> Left . ExternalHttpResourceUnavailable $ responseStatus resp+ other -> Left . ExternalResourceSomeError $ show other+ where+ retryAfterInfo :: Response a -> Maybe RetryAfter+ retryAfterInfo = readMaybe . decodeUtf8 <=< L.lookup hRetryAfter . responseHeaders++ checkFtp :: URI -> Bool -> ExceptT VerifyError IO ()+ checkFtp uri secure = do+ -- get authority which stores host and port+ authority <- case uriAuthority uri of+ Right a -> pure a+ Left _ -> throwError $+ ExternalResourceInvalidUrl (Just "FTP path must be absolute")+ let host = toString $ authHost authority+ port :: Int <- case toIntegralSized . fromMaybe 21 $ authPort authority of+ Just p -> pure p+ Nothing -> throwError $+ ExternalResourceInvalidUrl (Just "Bad port")+ -- build path from pieces+ path <- case uriPath uri of+ Nothing -> pure ""+ Just (_, pieces) -> pure+ . mconcat+ . intersperse "/"+ . map toString+ . toList+ $ pieces+ makeFtpRequest host port path secure `catch` \e ->+ throwError $ ExternalFtpException e++ makeFtpRequest+ :: String+ -> Int+ -> FilePath+ -> Bool+ -> ExceptT VerifyError IO ()+ makeFtpRequest host port path secure = handler host port $+ \handle response -> do+ -- check connection status+ when (frStatus response /= Success) $+ throwError $ ExternalFtpResourceUnavailable response+ -- anonymous login+ loginResp <- login handle "anonymous" ""+ -- check login status+ when (frStatus loginResp /= Success) $+ if vcIgnoreAuthFailures+ 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 ]+ 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+ UnsuccessfulException _ -> throwError $ FtpEntryDoesNotExist path+ FailureException FTPResponse{..} | frCode == 550 ->+ throwError $ FtpEntryDoesNotExist path+ err -> liftIO $ throwIO err+ pure ()+ where+ handler = if secure then withFTPS else withFTP
tests/Main.hs view
@@ -3,6 +3,8 @@ - SPDX-License-Identifier: MPL-2.0 -} +import Universum+ import Spec (spec) import Test.Hspec (hspec)
+ tests/Test/Xrefcheck/AnchorsInHeadersSpec.hs view
@@ -0,0 +1,27 @@+{- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++module Test.Xrefcheck.AnchorsInHeadersSpec where++import Universum++import Test.Hspec (Spec, describe, it, shouldBe)++import Xrefcheck.Core+import Test.Xrefcheck.Util++spec :: Spec+spec = do+ describe "Anchors in headers" $ do+ it "Check if anchors in headers are recognized" $ do+ fi <- getFI GitHub "tests/markdowns/without-annotations/anchors_in_headers.md"+ getAnchors fi `shouldBe` ["some-stuff", "stuff-section"]++ it "Check if anchors with id attributes are recognized" $ do+ fi <- getFI GitHub "tests/markdowns/without-annotations/anchors_in_headers_with_id_attribute.md"+ getAnchors fi `shouldBe` ["some-stuff-with-id-attribute", "stuff-section-with-id-attribute"]+ where+ getAnchors :: FileInfo -> [Text]+ getAnchors fi = map aName $ fi ^. fiAnchors
tests/Test/Xrefcheck/AnchorsSpec.hs view
@@ -3,122 +3,134 @@ - SPDX-License-Identifier: MPL-2.0 -} -module Test.Xrefcheck.AnchorsSpec where+module Test.Xrefcheck.AnchorsSpec (spec) where -import Test.Hspec (Spec, describe, it)+import Universum++import Test.Hspec (Spec, describe, it, shouldBe) import Test.QuickCheck ((===)) -import Xrefcheck.Core (Flavor (..), headerToAnchor)+import Test.Xrefcheck.Util+import Xrefcheck.Core checkHeaderConversions :: HasCallStack => Flavor -> [(Text, Text)] -> Spec checkHeaderConversions fl suites =- describe (show fl) $+ describe (show fl) $ do forM_ suites $ \(a, b) -> it (show a <> " == " <> show b) $ headerToAnchor fl a === b+ it "Non-stripped header name should be stripped" $ do+ fi <- getFI fl "tests/markdowns/without-annotations/non_stripped_spaces.md"+ getAnchors fi `shouldBe` [ case fl of GitHub -> "header--with-leading-spaces"+ GitLab -> "header-with-leading-spaces"+ , "edge-case"+ ]+ where+ getAnchors :: FileInfo -> [Text]+ getAnchors fi = map aName $ fi ^. fiAnchors spec :: Spec spec = do- describe "Header-to-anchor conversion" $ do- checkHeaderConversions GitHub- [ ( "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"- )- , ( "a \\ b"- , "a--b"- )- , ( "a + b"- , "a--b"- )- , ( "a+b"- , "ab"- )- , ( "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-"- )- , ( "- A -"- , "--a--"- )- , ( "Some-+++++--mess++-mda"- , "some---mess-mda"- )- , ( ":white_check_mark: Checklist for your Pull Request"- , "white_check_mark-checklist-for-your-pull-request"- )- ]+ describe "Header-to-anchor conversion" $ do+ checkHeaderConversions GitHub+ [ ( "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"+ )+ , ( "a \\ b"+ , "a--b"+ )+ , ( "a + b"+ , "a--b"+ )+ , ( "a+b"+ , "ab"+ )+ , ( "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-"+ )+ , ( "- A -"+ , "--a--"+ )+ , ( "Some-+++++--mess++-mda"+ , "some---mess-mda"+ )+ , ( ":white_check_mark: Checklist for your Pull Request"+ , "white_check_mark-checklist-for-your-pull-request"+ )+ ] - checkHeaderConversions GitLab- [ ( "a # b"- , "a-b"- )- , ( "a - b"- , "a-b"- )- , ( "a -- b"- , "a-b"- )- , ( "a & b"- , "a-b"- )- , ( "a + b"- , "a-b"- )- , ( "a+b"- , "ab"- )- , ( "a - -- - b"- , "a-b"- )- , ( "a -+--|- b"- , "a-b"- )- , ( "Some *italic* text"- , "some-italic-text"- )- , ( "-Some-text-with--many----hyphens-"- , "-some-text-with-many-hyphens-"- )- , ( "- A -"- , "-a-"- )- , ( "Some-+++++--mess++-mda"- , "some-mess-mda"- )- , ( ":white_check_mark: Checklist for your Pull Request"- , "white_check_mark-checklist-for-your-pull-request"- )- ]+ checkHeaderConversions GitLab+ [ ( "a # b"+ , "a-b"+ )+ , ( "a - b"+ , "a-b"+ )+ , ( "a -- b"+ , "a-b"+ )+ , ( "a & b"+ , "a-b"+ )+ , ( "a + b"+ , "a-b"+ )+ , ( "a+b"+ , "ab"+ )+ , ( "a - -- - b"+ , "a-b"+ )+ , ( "a -+--|- b"+ , "a-b"+ )+ , ( "Some *italic* text"+ , "some-italic-text"+ )+ , ( "-Some-text-with--many----hyphens-"+ , "-some-text-with-many-hyphens-"+ )+ , ( "- A -"+ , "-a-"+ )+ , ( "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
@@ -1,17 +1,27 @@-{- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>+{- SPDX-FileCopyrightText: 2019-2021 Serokell <https://serokell.io> - - SPDX-License-Identifier: MPL-2.0 -} module Test.Xrefcheck.ConfigSpec where -import qualified Data.ByteString as BS-import Test.Hspec (Spec, before, describe, it)-import Test.QuickCheck (counterexample, ioProperty, once)+import Universum -import Xrefcheck.Config-import Xrefcheck.Core+import Control.Concurrent (forkIO, killThread)+import Control.Exception qualified as E +import Data.ByteString qualified as BS+import Network.HTTP.Types (Status (..))+import Test.Hspec (Spec, before, describe, it, shouldBe)+import Test.Hspec.Expectations (expectationFailure)+import Test.QuickCheck (ioProperty, once)++import Xrefcheck.Config (Config, Config' (..), VerifyConfig' (..), defConfig, defConfigText)+import Xrefcheck.Core (Flavor (GitHub), allFlavors)+import Xrefcheck.Verify (VerifyError (..), VerifyResult (..), checkExternalResource)++import Test.Xrefcheck.Util (mockServer)+ spec :: Spec spec = do describe "Default config is valid" $@@ -25,12 +35,40 @@ -- stack exec xrefcheck -- dump-config -t GitHub -o tests/configs/github-config.yaml it "Config matches" $ \config ->- counterexample- (toString $ unwords- [ "Config does not match the expected format."- , "Run"- , "`stack exec xrefcheck -- dump-config -t GitHub -o tests/configs/github-config.yaml`"- , "and verify changes"- ]- )- (config == defConfigText GitHub)+ when (config /= defConfigText GitHub) $+ expectationFailure $ toString $ unwords+ [ "Config does not match the expected format."+ , "Run"+ , "`stack exec xrefcheck -- dump-config -t GitHub -o tests/configs/github-config.yaml`"+ , "and verify changes"+ ]++ describe "`ignoreAuthFailures` working as expected" $ do+ let config = (cVerification $ defConfig GitHub) { vcIgnoreRefs = [] }++ it "when True - assume 401 status is valid" $+ checkLinkWithServer (config { vcIgnoreAuthFailures = True })+ "http://127.0.0.1:3000/401" $ VerifyResult []++ it "when False - assume 401 status is invalid" $+ checkLinkWithServer (config { vcIgnoreAuthFailures = False })+ "http://127.0.0.1:3000/401" $ VerifyResult+ [ ExternalHttpResourceUnavailable $+ Status { statusCode = 401, statusMessage = "Unauthorized" }+ ]++ it "when True - assume 403 status is valid" $+ checkLinkWithServer (config { vcIgnoreAuthFailures = True })+ "http://127.0.0.1:3000/403" $ VerifyResult []++ it "when False - assume 403 status is invalid" $+ checkLinkWithServer (config { vcIgnoreAuthFailures = False })+ "http://127.0.0.1:3000/403" $ VerifyResult+ [ ExternalHttpResourceUnavailable $+ Status { statusCode = 403, statusMessage = "Forbidden" }+ ]+ where+ checkLinkWithServer config link expectation =+ E.bracket (forkIO mockServer) killThread $ \_ -> do+ result <- checkExternalResource config link+ result `shouldBe` expectation
tests/Test/Xrefcheck/IgnoreAnnotationsSpec.hs view
@@ -5,52 +5,51 @@ module Test.Xrefcheck.IgnoreAnnotationsSpec where -import qualified Data.ByteString.Lazy as BSL-import Test.Hspec (Spec, describe, it, shouldBe)+import Universum +import CMarkGFM (PosInfo (..))+import Test.Hspec (Spec, describe, it, shouldBe, shouldReturn)++import Test.Xrefcheck.Util import Xrefcheck.Core+import Xrefcheck.Scan import Xrefcheck.Scanners.Markdown spec :: Spec spec = do- describe "Parsing failures" $ do- it "Check if parsing incorrect markdowns produce exceptions" $ do- areIncorrect <- mapM isIncorrectMD failPaths- or areIncorrect `shouldBe` True- describe "\"ignore link\" mode" $ do- it "Check \"ignore link\" performance" $ do- fi <- getFI "tests/markdowns/with-annotations/ignore_link.md"- (getRefs fi) `shouldBe` ["team", "team", "team", "hire-us", "how-we-work", "privacy"]- describe "\"ignore paragraph\" mode" $ do- it "Check \"ignore paragraph\" performance" $ do- fi <- getFI "tests/markdowns/with-annotations/ignore_paragraph.md"- (getRefs fi) `shouldBe` ["blog", "contacts"]- describe "\"ignore file\" mode" $ do- it "Check \"ignore file\" performance" $ do- fi <- getFI "tests/markdowns/with-annotations/ignore_file.md"- (getRefs fi) `shouldBe` []- where- failPaths :: [FilePath]- failPaths =- [ "tests/markdowns/with-annotations/no_link.md"- , "tests/markdowns/with-annotations/no_paragraph.md"- , "tests/markdowns/with-annotations/unexpected_ignore_file.md"- , "tests/markdowns/with-annotations/unrecognised_option.md"- ]-- parse :: FilePath -> IO (Either Text FileInfo)- parse path =- parseFileInfo defGithubMdConfig . decodeUtf8 <$> BSL.readFile path-- getFI :: FilePath -> IO FileInfo- getFI path =- let errOrFI = parse path- in either error id <$> errOrFI-- getRefs :: FileInfo -> [Text]- getRefs fi = map rName $ fi ^. fiReferences+ describe "Parsing failures" $ do+ it "Check if broken link annotation produce error" do+ let file = "tests/markdowns/with-annotations/no_link.md"+ getErrs file `shouldReturn`+ makeError (Just $ PosInfo 7 1 7 31) file Link ""+ it "Check if broken paragraph annotation produce error" do+ let file = "tests/markdowns/with-annotations/no_paragraph.md"+ getErrs file `shouldReturn`+ makeError (Just $ PosInfo 7 1 7 35) file Paragraph "HEADING"+ it "Check if broken ignore file annotation produce error" do+ let file = "tests/markdowns/with-annotations/unexpected_ignore_file.md"+ getErrs file `shouldReturn`+ makeError (Just $ PosInfo 9 1 9 30) file File ""+ it "Check if broken unrecognised annotation produce error" do+ let file = "tests/markdowns/with-annotations/unrecognised_option.md"+ getErrs file `shouldReturn`+ makeError (Just $ PosInfo 7 1 7 46) file None "unrecognised-option"+ describe "\"ignore link\" mode" $ do+ it "Check \"ignore link\" performance" $ do+ fi <- getFI GitHub "tests/markdowns/with-annotations/ignore_link.md"+ getRefs fi `shouldBe`+ ["team", "team", "team", "hire-us", "how-we-work", "privacy", "link2", "link2"]+ describe "\"ignore paragraph\" mode" $ do+ it "Check \"ignore paragraph\" performance" $ do+ fi <- getFI GitHub "tests/markdowns/with-annotations/ignore_paragraph.md"+ getRefs fi `shouldBe` ["blog", "contacts"]+ describe "\"ignore file\" mode" $ do+ it "Check \"ignore file\" performance" $ do+ fi <- getFI GitHub "tests/markdowns/with-annotations/ignore_file.md"+ getRefs fi `shouldBe` []+ where+ getRefs :: FileInfo -> [Text]+ getRefs fi = map rName $ fi ^. fiReferences - isIncorrectMD :: FilePath -> IO Bool- isIncorrectMD path = do- errOrInfo <- parse path- return $ isLeft errOrInfo+ getErrs :: FilePath -> IO [ScanError]+ getErrs path = snd <$> parse GitHub path
tests/Test/Xrefcheck/IgnoreRegexSpec.hs view
@@ -5,6 +5,8 @@ module Test.Xrefcheck.IgnoreRegexSpec where +import Universum+ import Data.Yaml (decodeEither') import Test.HUnit (assertFailure) import Test.Hspec (Spec, describe, it)@@ -13,71 +15,72 @@ import Xrefcheck.Config import Xrefcheck.Core import Xrefcheck.Progress (allowRewrite)-import Xrefcheck.Scan (gatherRepoInfo, specificFormatsSupport)+import Xrefcheck.Scan (scanRepo, specificFormatsSupport, ScanResult (..)) import Xrefcheck.Scanners.Markdown import Xrefcheck.Verify (VerifyError, VerifyResult, WithReferenceLoc (..), verifyErrors, verifyRepo) spec :: Spec spec = do- describe "Regular expressions performance" $ do- let root = "tests/markdowns/without-annotations"- let showProgressBar = False- let formats = specificFormatsSupport [markdownSupport defGithubMdConfig]- let verifyMode = ExternalOnlyMode+ describe "Regular expressions performance" $ do+ let root = "tests/markdowns/without-annotations"+ let showProgressBar = False+ let formats = specificFormatsSupport [markdownSupport defGithubMdConfig]+ let verifyMode = ExternalOnlyMode - let linksTxt =- [ "https://bad.((external.)?)reference(/?)"- , "https://bad.reference.(org|com)"- ]- let regexs = linksToRegexs linksTxt- let config = setIgnoreRefs regexs (defConfig GitHub)+ let linksTxt =+ [ "https://bad.((external.)?)reference(/?)"+ , "https://bad.reference.(org|com)"+ ]+ let regexs = linksToRegexs linksTxt+ let config = setIgnoreRefs regexs (defConfig GitHub) - it "Check that only not matched links are verified" $ do- repoInfo <- allowRewrite showProgressBar $ \rw ->- gatherRepoInfo rw formats (config ^. cTraversalL) root+ it "Check that only not matched links are verified" $ do+ scanResult <- allowRewrite showProgressBar $ \rw ->+ scanRepo rw formats (config ^. cTraversalL) root - verifyRes <- allowRewrite showProgressBar $ \rw ->- verifyRepo rw (config ^. cVerificationL) verifyMode root repoInfo+ verifyRes <- allowRewrite showProgressBar $ \rw ->+ verifyRepo rw (config ^. cVerificationL) verifyMode root $ srRepoInfo scanResult - let brokenLinks = pickBrokenLinks verifyRes+ let brokenLinks = pickBrokenLinks verifyRes - let matchedLinks =- [ "https://bad.referenc/"- , "https://bad.reference"- , "https://bad.external.reference/"- , "https://bad.external.reference"- , "https://bad.reference.org"- , "https://bad.reference.com"- ]+ let matchedLinks =+ [ "https://bad.referenc/"+ , "https://bad.reference"+ , "https://bad.external.reference/"+ , "https://bad.external.reference"+ , "https://bad.reference.org"+ , "https://bad.reference.com"+ ] - let notMatchedLinks =- [ "https://non-existent.reference/"- , "https://bad.externall.reference"- , "https://bad.reference.io"- ]+ let notMatchedLinks =+ [ "https://non-existent.reference/"+ , "https://bad.externall.reference"+ , "https://bad.reference.io"+ ] - forM_ matchedLinks $ \link -> do- when (link `elem` brokenLinks) $- assertFailure $ "Link \"" <> show link <>- "\" is considered as broken but it should be ignored"+ forM_ matchedLinks $ \link -> do+ when (link `elem` brokenLinks) $+ assertFailure $+ "Link \"" <> show link <>+ "\" is considered as broken but it should be ignored" - forM_ notMatchedLinks $ \link -> do- when (link `notElem` brokenLinks) $- assertFailure $ "Link \"" <> show link <>- "\" is not considered as broken but it is (and shouldn't be ignored)"+ forM_ notMatchedLinks $ \link -> do+ when (link `notElem` brokenLinks) $+ assertFailure $+ "Link \"" <> show link <>+ "\" is not considered as broken but it is (and shouldn't be ignored)" where- pickBrokenLinks :: VerifyResult (WithReferenceLoc VerifyError) -> [Text]- pickBrokenLinks verifyRes =- case verifyErrors verifyRes of- Just neWithRefLoc -> map (rLink . wrlReference) $ toList neWithRefLoc- Nothing -> []+ pickBrokenLinks :: VerifyResult (WithReferenceLoc VerifyError) -> [Text]+ pickBrokenLinks verifyRes =+ case verifyErrors verifyRes of+ Just neWithRefLoc -> map (rLink . wrlReference) $ toList neWithRefLoc+ Nothing -> [] - linksToRegexs :: [Text] -> Maybe [Regex]- linksToRegexs links =- let errOrRegexs = map (decodeEither' . encodeUtf8) links- maybeRegexs = map (either (error . show) Just) errOrRegexs- in sequence maybeRegexs+ linksToRegexs :: [Text] -> [Regex]+ linksToRegexs links =+ let errOrRegexs = map (decodeEither' . encodeUtf8) links+ in map (either (error . show) id) errOrRegexs - setIgnoreRefs :: Maybe [Regex] -> Config -> Config- setIgnoreRefs regexs = (cVerificationL . vcIgnoreRefsL) .~ regexs+ setIgnoreRefs :: [Regex] -> Config -> Config+ setIgnoreRefs regexs = (cVerificationL . vcIgnoreRefsL) .~ regexs
tests/Test/Xrefcheck/LocalSpec.hs view
@@ -5,6 +5,8 @@ module Test.Xrefcheck.LocalSpec where +import Universum+ import Test.Hspec (Spec, describe, it) import Test.QuickCheck ((===)) @@ -12,12 +14,12 @@ spec :: Spec spec = do- describe "Local refs canonizing" $ do- it "Strips ./" $- canonizeLocalRef "./AnchorsSpec.hs" === "AnchorsSpec.hs"+ describe "Local refs canonizing" $ do+ it "Strips ./" $+ canonizeLocalRef "./AnchorsSpec.hs" === "AnchorsSpec.hs" - it "Strips ././" $- canonizeLocalRef "././AnchorsSpec.hs" === "AnchorsSpec.hs"+ it "Strips ././" $+ canonizeLocalRef "././AnchorsSpec.hs" === "AnchorsSpec.hs" - it "Leaves plain other intact" $- canonizeLocalRef "../AnchorsSpec.hs" === "../AnchorsSpec.hs"+ it "Leaves plain other intact" $+ canonizeLocalRef "../AnchorsSpec.hs" === "../AnchorsSpec.hs"
+ tests/Test/Xrefcheck/TooManyRequestsSpec.hs view
@@ -0,0 +1,217 @@+{- SPDX-FileCopyrightText: 2021 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++module Test.Xrefcheck.TooManyRequestsSpec where++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.Time (addUTCTime, formatTime, getCurrentTime, defaultTimeLocale, 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 Test.Hspec (Spec, describe, it, shouldBe)+import Test.HUnit (assertBool)+import Time (sec, (-:-))+import Web.Firefly (ToResponse (toResponse), route, run, getMethod)++import Xrefcheck.Config+import Xrefcheck.Core+import Xrefcheck.Progress+import Xrefcheck.Util+import Xrefcheck.Verify++spec :: Spec+spec = do+ describe "429 response tests" $ do+ it "Returns 200 eventually" $ do+ let prog = Progress{ pTotal = 1+ , pCurrent = 1+ , pErrorsUnfixable = 0+ , pErrorsFixable = 0+ , pTaskTimestamp = Nothing+ }+ checkLinkAndProgressWithServer (mock429 "1" ok200)+ "http://127.0.0.1:5000/429" prog $ VerifyResult []+ it "Returns 503 eventually" $ do+ let prog = Progress{ pTotal = 1+ , pCurrent = 1+ , pErrorsUnfixable = 1+ , pErrorsFixable = 0+ , pTaskTimestamp = Nothing+ }+ checkLinkAndProgressWithServer (mock429 "1" serviceUnavailable503)+ "http://127.0.0.1:5000/429" prog $ VerifyResult+ [ ExternalHttpResourceUnavailable $+ Status { statusCode = 503, statusMessage = "Service Unavailable"}+ ]+ it "Successfully updates the new retry-after value (as seconds)" $ do+ E.bracket (forkIO $ mock429 "2" ok200) killThread $ \_ -> do+ now <- getPOSIXTime <&> posixTimeToTimeSecond+ 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))+ }+ }+ _ <- verifyReferenceWithProgress+ (Reference "" "http://127.0.0.1:5000/429" Nothing (Position Nothing))+ progressRef+ Progress{..} <- vrExternal <$> readIORef progressRef+ let ttc = ttTimeToCompletion <$> pTaskTimestamp+ flip assertBool (ttc == Just (sec 2)) $+ "Expected time to completion be equal to " ++ show (Just $ sec 2) +++ ", but instead it's " ++ show ttc+ it "Successfully updates the new retry-after value (as date)" $ do+ utctime <- getCurrentTime+ let+ -- 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+ 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))+ }+ }+ _ <- verifyReferenceWithProgress+ (Reference "" "http://127.0.0.1:5000/429" Nothing (Position Nothing))+ progressRef+ Progress{..} <- vrExternal <$> readIORef progressRef+ let ttc = fromMaybe (sec 0) $ ttTimeToCompletion <$> pTaskTimestamp+ 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+ it "Sets the new retry-after to 0 seconds if its value is a date && has already passed" $ do+ utctime <- getCurrentTime+ let+ -- 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+ 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))+ }+ }+ _ <- verifyReferenceWithProgress+ (Reference "" "http://127.0.0.1:5000/429" Nothing (Position Nothing))+ progressRef+ Progress{..} <- vrExternal <$> readIORef progressRef+ let ttc = ttTimeToCompletion <$> pTaskTimestamp+ flip assertBool (ttc == Just (sec 0)) $+ "Expected time to completion be 0 seconds" +++ ", but instead it's " ++ show ttc+ it "The GET request should not be attempted after catching a 429" $ do+ let+ mock429WithGlobalIORef :: IORef [(Text, Status)] -> IO ()+ mock429WithGlobalIORef infoReverseAccumulatorRef = do+ callCountRef <- newIORef @_ @Int 0+ run 5000 $ do+ route "/429grandfinale" $ do+ m <- getMethod+ callCount <- atomicModifyIORef' callCountRef $ \cc -> (cc + 1, cc)+ atomicModifyIORef' infoReverseAccumulatorRef $ \lst ->+ ( ( m+ , if | m == "GET" -> ok200+ | callCount == 0 -> tooManyRequests429+ | otherwise -> serviceUnavailable503+ ) : 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)+ infoReverseAccumulatorRef <- newIORef []+ E.bracket (forkIO $ mock429WithGlobalIORef infoReverseAccumulatorRef) killThread $ \_ -> do+ _ <- verifyLink "http://127.0.0.1:5000/429grandfinale"+ infoReverseAccumulator <- readIORef infoReverseAccumulatorRef+ reverse infoReverseAccumulator `shouldBe`+ [ ("HEAD", tooManyRequests429)+ , ("HEAD", serviceUnavailable503)+ , ("GET", ok200)+ ]+ 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) "." "" reference++ -- | 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 retryAfter status = do+ callCountRef <- newIORef @_ @Int 0+ run 5000 $+ route "/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)
+ tests/Test/Xrefcheck/TrailingSlashSpec.hs view
@@ -0,0 +1,48 @@+{- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++module Test.Xrefcheck.TrailingSlashSpec where++import Universum++import Fmt (blockListF, pretty, unlinesF)+import System.Directory (doesFileExist)+import Test.Hspec (Spec, describe, expectationFailure, it)++import Xrefcheck.Config+import Xrefcheck.Core+import Xrefcheck.Progress+import Xrefcheck.Scan+import Xrefcheck.Scanners.Markdown++spec :: Spec+spec = do+ describe "Trailing forward slash detection" $ do+ let config = defConfig GitHub+ let format = specificFormatsSupport [markdownSupport (scMarkdown (cScanners config))]+ forM_ roots $ \root -> do+ it ("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+ return $ if predicate+ then Right ()+ else Left filePath)+ if null nonExistentFiles+ then pass+ else expectationFailure $ pretty $ unlinesF+ [ "Expected all filepaths to be valid, but these filepaths do not exist:"+ , blockListF nonExistentFiles+ ]+ where+ roots :: [FilePath]+ roots =+ [ "tests/markdowns/without-annotations"+ , "tests/markdowns/without-annotations/"+ , "tests/markdowns/without-annotations/./"+ ]
+ tests/Test/Xrefcheck/URIParsingSpec.hs view
@@ -0,0 +1,53 @@+{- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++{-# LANGUAGE QuasiQuotes #-}++module Test.Xrefcheck.URIParsingSpec where++import Universum++import Test.Hspec (Spec, describe, it, shouldReturn)+import Text.URI (URI)+import Text.URI.QQ (uri)+import URI.ByteString (URIParseError (..), SchemaError (..))++import Xrefcheck.Verify (parseUri, VerifyError (..))++spec :: Spec+spec = do+ describe "URI parsing should be successful" $ do+ it "Without the special characters in the query strings" do+ parseUri' "https://example.com/?q=a&p=b#fragment" `shouldReturn`+ Right [uri|https://example.com/?q=a&p=b#fragment|]++ parseUri' "https://example.com/path/to/smth?q=a&p=b" `shouldReturn`+ Right [uri|https://example.com/path/to/smth?q=a&p=b|]++ it "With the special characters in the query strings" do+ parseUri' "https://example.com/?q=[a]&<p>={b}#fragment" `shouldReturn`+ Right [uri|https://example.com/?q=%5Ba%5D&%3Cp%3E=%7Bb%7D#fragment|]++ parseUri' "https://example.com/path/to/smth?q=[a]&<p>={b}" `shouldReturn`+ Right [uri|https://example.com/path/to/smth?q=%5Ba%5D&%3Cp%3E=%7Bb%7D|]++ describe "URI parsing should be unsuccessful" $ do+ it "With the special characters anywhere else" do+ parseUri' "https://exa<mple.co>m/?q=a&p=b#fra{g}ment" `shouldReturn`+ Left (ExternalResourceInvalidUri MalformedPath)++ parseUri' "https://example.com/pa[t]h/to[/]smth?q=a&p=b" `shouldReturn`+ Left (ExternalResourceInvalidUri MalformedPath)++ it "With malformed scheme" do+ parseUri' "https//example.com/" `shouldReturn`+ Left (ExternalResourceInvalidUri $ MalformedScheme MissingColon)++ it "With malformed fragment" do+ parseUri' "https://example.com/?q=a&p=b#fra{g}ment" `shouldReturn`+ Left (ExternalResourceInvalidUri MalformedFragment)+ where+ parseUri' :: Text -> IO $ Either VerifyError URI+ parseUri' = runExceptT . parseUri
+ tests/Test/Xrefcheck/Util.hs view
@@ -0,0 +1,26 @@+{- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}++module Test.Xrefcheck.Util where++import Universum++import Network.HTTP.Types (forbidden403, unauthorized401)+import Web.Firefly (ToResponse (..), route, run)++import Xrefcheck.Core (FileInfo, Flavor)+import Xrefcheck.Scan (ScanError)+import Xrefcheck.Scanners.Markdown (MarkdownConfig' (MarkdownConfig, mcFlavor), markdownScanner)++parse :: Flavor -> FilePath -> IO (FileInfo, [ScanError])+parse fl path = markdownScanner MarkdownConfig { mcFlavor = fl } path++getFI :: Flavor -> FilePath -> IO FileInfo+getFI fl path = fst <$> parse fl path++mockServer :: IO ()+mockServer = run 3000 $ do+ route "/401" $ pure $ toResponse ("" :: Text, unauthorized401)+ route "/403" $ pure $ toResponse ("" :: Text, forbidden403)
xrefcheck.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: xrefcheck-version: 0.2+version: 0.2.1 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@@ -18,7 +18,6 @@ extra-source-files: README.md CHANGES.md- src-files/def-config.yaml source-repository head type: git@@ -27,8 +26,11 @@ library exposed-modules: Xrefcheck.CLI+ Xrefcheck.Command Xrefcheck.Config+ Xrefcheck.Config.Default Xrefcheck.Core+ Xrefcheck.Orphans Xrefcheck.Progress Xrefcheck.Scan Xrefcheck.Scanners@@ -45,19 +47,23 @@ default-extensions: AllowAmbiguousTypes BangPatterns+ BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveGeneric+ DerivingStrategies FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving+ ImportQualifiedPost LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns+ NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards@@ -70,24 +76,24 @@ ViewPatterns TypeApplications TypeOperators- ghc-options: -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns+ 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 build-depends: Glob- , HUnit , aeson , aeson-casing , async- , base <4.15+ , base >=4.14.3.0 && <5 , bytestring , cmark-gfm , containers , data-default- , deepseq , directory , directory-tree- , file-embed+ , dlist+ , exceptions , filepath , fmt+ , ftp-client , http-client , http-types , lens@@ -96,22 +102,19 @@ , o-clock , optparse-applicative , pretty-terminal+ , raw-strings-qq , regex-tdfa , req , roman-numerals- , template-haskell+ , tagsoup , text , text-metrics , th-lift-instances- , th-utilities+ , time , transformers , universum- , with-utf8+ , uri-bytestring , yaml- mixins:- base hiding (Prelude)- , universum (Universum as Prelude)- , universum (Universum.Unsafe as Unsafe) default-language: Haskell2010 executable xrefcheck@@ -125,19 +128,23 @@ default-extensions: AllowAmbiguousTypes BangPatterns+ BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveGeneric+ DerivingStrategies FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving+ ImportQualifiedPost LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns+ NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards@@ -150,61 +157,86 @@ ViewPatterns TypeApplications TypeOperators- ghc-options: -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns -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 -threaded -rtsopts -with-rtsopts=-N -O2 build-depends:- Glob- , HUnit- , aeson- , aeson-casing- , async- , base <4.15+ base >=4.14.3.0 && <5 , bytestring- , cmark-gfm- , containers- , data-default- , deepseq- , directory- , directory-tree- , file-embed- , filepath- , fmt- , http-client- , http-types- , lens- , modern-uri- , mtl- , o-clock- , optparse-applicative- , pretty-terminal- , regex-tdfa- , req- , roman-numerals- , template-haskell- , text- , text-metrics- , th-lift-instances- , th-utilities- , transformers , universum , with-utf8 , xrefcheck- , yaml- mixins:- base hiding (Prelude)- , universum (Universum as Prelude)- , universum (Universum.Unsafe as Unsafe) default-language: Haskell2010 +test-suite links-tests+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Test.Xrefcheck.FtpLinks+ Tree+ Paths_xrefcheck+ autogen-modules:+ Paths_xrefcheck+ hs-source-dirs:+ links-tests+ default-extensions:+ AllowAmbiguousTypes+ BangPatterns+ BlockArguments+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveDataTypeable+ DeriveGeneric+ DerivingStrategies+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GeneralizedNewtypeDeriving+ ImportQualifiedPost+ LambdaCase+ MultiParamTypeClasses+ MultiWayIf+ NamedFieldPuns+ NoImplicitPrelude+ OverloadedStrings+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ StandaloneDeriving+ TemplateHaskell+ TupleSections+ TypeFamilies+ 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+ build-tool-depends:+ tasty-discover:tasty-discover+ build-depends:+ base >=4.14.3.0 && <5+ , optparse-applicative+ , tagged+ , tasty+ , tasty-hunit+ , universum+ , xrefcheck+ default-language: Haskell2010+ test-suite xrefcheck-tests type: exitcode-stdio-1.0 main-is: Main.hs other-modules: Spec+ Test.Xrefcheck.AnchorsInHeadersSpec Test.Xrefcheck.AnchorsSpec Test.Xrefcheck.ConfigSpec Test.Xrefcheck.IgnoreAnnotationsSpec Test.Xrefcheck.IgnoreRegexSpec Test.Xrefcheck.LocalSpec+ Test.Xrefcheck.TooManyRequestsSpec+ Test.Xrefcheck.TrailingSlashSpec+ Test.Xrefcheck.URIParsingSpec+ Test.Xrefcheck.Util Paths_xrefcheck autogen-modules: Paths_xrefcheck@@ -213,19 +245,23 @@ default-extensions: AllowAmbiguousTypes BangPatterns+ BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveGeneric+ DerivingStrategies FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving+ ImportQualifiedPost LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns+ NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards@@ -238,51 +274,29 @@ ViewPatterns TypeApplications TypeOperators- ghc-options: -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns+ 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 build-tool-depends: hspec-discover:hspec-discover build-depends:- Glob- , HUnit+ HUnit , QuickCheck- , aeson- , aeson-casing- , async- , base <4.15+ , base >=4.14.3.0 && <5 , bytestring+ , case-insensitive , cmark-gfm , containers- , data-default- , deepseq , directory- , directory-tree- , file-embed- , filepath+ , firefly , fmt , hspec- , http-client+ , hspec-expectations , http-types- , lens , modern-uri- , mtl , o-clock- , optparse-applicative- , pretty-terminal , regex-tdfa- , req- , roman-numerals- , template-haskell- , text- , text-metrics- , th-lift-instances- , th-utilities- , transformers+ , time , universum- , with-utf8+ , uri-bytestring , xrefcheck , yaml- mixins:- base hiding (Prelude)- , universum (Universum as Prelude)- , universum (Universum.Unsafe as Unsafe) default-language: Haskell2010