xrefcheck 0.2.1 → 0.2.2
raw patch · 35 files changed
+967/−668 lines, 35 filesdep +processdep +reflectiondep +tasty-quickcheckdep −HUnitdep −QuickCheckdep −directory-treedep ~cmark-gfm
Dependencies added: process, reflection, tasty-quickcheck
Dependencies removed: HUnit, QuickCheck, directory-tree, hspec, hspec-expectations, roman-numerals
Dependency ranges changed: cmark-gfm
Files
- CHANGES.md +35/−0
- README.md +4/−0
- ftp-tests/Main.hs +21/−0
- ftp-tests/Test/Xrefcheck/FtpLinks.hs +85/−0
- ftp-tests/Tree.hs +5/−0
- links-tests/Main.hs +0/−21
- links-tests/Test/Xrefcheck/FtpLinks.hs +0/−84
- links-tests/Tree.hs +0/−5
- src/Xrefcheck/CLI.hs +9/−5
- src/Xrefcheck/Command.hs +8/−3
- src/Xrefcheck/Config.hs +21/−33
- src/Xrefcheck/Config/Default.hs +1/−6
- src/Xrefcheck/Core.hs +55/−40
- src/Xrefcheck/Orphans.hs +2/−2
- src/Xrefcheck/Progress.hs +16/−16
- src/Xrefcheck/Scan.hs +79/−38
- src/Xrefcheck/Scanners/Markdown.hs +163/−121
- src/Xrefcheck/System.hs +26/−11
- src/Xrefcheck/Util.hs +4/−12
- src/Xrefcheck/Util/Colorize.hs +46/−0
- src/Xrefcheck/Verify.hs +115/−36
- tests/Main.hs +10/−7
- tests/Spec.hs +0/−6
- tests/Test/Xrefcheck/AnchorsInHeadersSpec.hs +17/−15
- tests/Test/Xrefcheck/AnchorsSpec.hs +21/−21
- tests/Test/Xrefcheck/ConfigSpec.hs +58/−42
- tests/Test/Xrefcheck/IgnoreAnnotationsSpec.hs +43/−33
- tests/Test/Xrefcheck/IgnoreRegexSpec.hs +21/−17
- tests/Test/Xrefcheck/LocalSpec.hs +11/−11
- tests/Test/Xrefcheck/TooManyRequestsSpec.hs +23/−22
- tests/Test/Xrefcheck/TrailingSlashSpec.hs +14/−14
- tests/Test/Xrefcheck/URIParsingSpec.hs +34/−30
- tests/Test/Xrefcheck/Util.hs +1/−4
- tests/Tree.hs +5/−0
- xrefcheck.cabal +14/−13
CHANGES.md view
@@ -7,6 +7,41 @@ Unreleased ========== +0.2.2+==========++* [#145](https://github.com/serokell/xrefcheck/pull/145)+ + Add check that there is no unknown fields in config.+* [#158](https://github.com/serokell/xrefcheck/pull/158)+ + Fixed bug when we reported footnotes as broken links+* [#163](https://github.com/serokell/xrefcheck/pull/163)+ + Fixed an issue where the progress bar thread might be unexpectedly cancelled and jumble up the output.+* [#184](https://github.com/serokell/xrefcheck/pull/184)+ + Make `flavor` a required parameter.+* [#182](https://github.com/serokell/xrefcheck/pull/182)+ + Now we call references to anchors in current file (e.g. `[a](#b)`) as+ `current file` references instead of calling them `local` (which was ambigious).+* [#188](https://github.com/serokell/xrefcheck/pull/188)+ + Added CLI option `--no-colors` that disables ANSI colors in output.+ + Automatically disable coloring if it is not supported+* [#152](https://github.com/serokell/xrefcheck/pull/152)+ + Now we report links that target a file outside repository (e.g. `/../a.md`)+ as broken (with message `Link targets a local file outside repository`).+ Same for links that are using directories outside repository (e.g. `/../repo/a.md`),+ since such things are not supported by GitHub markdown renderer.+* [#174](https://github.com/serokell/xrefcheck/pull/174)+ + Make xrefcheck only scan files that are tracked by git.+ + Fixed bug where links to ignored files were valid.+ + Fixed bug where links with trailing slashes were invalid.+* [#198](https://github.com/serokell/xrefcheck/pull/198)+ + Now we're checking globs in config fields and CLI args (e.g. `ignored`),+ they must be valid globs relative to repository root (`foo/*` instead of `/foo/*`)+* [#196](https://github.com/serokell/xrefcheck/pull/196)+ + Now `xrefcheck: ignore link` annotation expects a link to ignore in next markdown node,+ instead of expecting link in whole rest of file.+ If you've got `Expected a LINK after "ignore link" annotation` message, see+ PR's description for examples and details.+ 0.2.1 ==========
README.md view
@@ -47,6 +47,10 @@ At the moment of writing, the listed solutions don't support ftp/ftps links. +## Dependencies [↑](#xrefcheck)++Xrefcheck requires you to have `git` version 2.18.0 or later in your PATH.+ ## Usage [↑](#xrefcheck) We provide the following ways for you to use xrefcheck:
+ ftp-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
+ ftp-tests/Test/Xrefcheck/FtpLinks.hs view
@@ -0,0 +1,85 @@+-- 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)+ ]
+ ftp-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 #-}
− links-tests/Main.hs
@@ -1,21 +0,0 @@--- 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
@@ -1,84 +0,0 @@--- 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
@@ -1,5 +0,0 @@--- 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/Xrefcheck/CLI.hs view
@@ -26,7 +26,7 @@ import Data.Text qualified as T import Data.Version (showVersion) import Options.Applicative- (Mod, OptionFields, Parser, ReadM, auto, command, eitherReader, execParser, flag',+ (Mod, OptionFields, Parser, ReadM, auto, command, eitherReader, execParser, flag, flag', footerDoc, fullDesc, help, helpDoc, helper, hsubparser, info, infoOption, long, metavar, option, progDesc, short, strOption, switch, value) import Options.Applicative.Help.Pretty (Doc, displayS, fill, fillSep, indent, renderPretty, text)@@ -36,8 +36,8 @@ import Xrefcheck.Config (VerifyConfig, VerifyConfig' (..)) import Xrefcheck.Core import Xrefcheck.Scan-import Xrefcheck.Util (normaliseWithNoTrailing)-import Xrefcheck.System (RelGlobPattern (..))+import Xrefcheck.System (RelGlobPattern, mkGlobPattern)+import Xrefcheck.Util (ColorMode (WithColors, WithoutColors), normaliseWithNoTrailing) modeReadM :: ReadM VerifyMode modeReadM = eitherReader $ \s ->@@ -74,6 +74,7 @@ , oMode :: VerifyMode , oVerbose :: Bool , oShowProgressBar :: Maybe Bool+ , oColorMode :: ColorMode , oTraversalOptions :: TraversalOptions , oVerifyOptions :: VerifyOptions }@@ -114,8 +115,8 @@ filepathOption :: Mod OptionFields FilePath -> Parser FilePath filepathOption = fmap normaliseWithNoTrailing <$> strOption -globOption :: Mod OptionFields FilePath -> Parser RelGlobPattern-globOption = fmap RelGlobPattern <$> filepathOption+globOption :: Mod OptionFields RelGlobPattern -> Parser RelGlobPattern+globOption = option $ eitherReader $ mkGlobPattern repoTypeReadM :: ReadM RepoType repoTypeReadM = eitherReader $ \name ->@@ -170,6 +171,9 @@ help "Do not display progress bar during verification." , pure Nothing ]+ oColorMode <- flag WithColors WithoutColors $+ long "no-color" <>+ help "Disable ANSI coloring of output" oTraversalOptions <- traversalOptionsParser oVerifyOptions <- verifyOptionsParser return Options{..}
src/Xrefcheck/Command.hs view
@@ -9,19 +9,22 @@ import Universum +import Data.Reflection (give) import Data.Yaml (decodeFileEither, prettyPrintParseException) import Fmt (blockListF', build, fmt, fmtLn, indentF)+import System.Console.Pretty (supportsPretty) import System.Directory (doesFileExist) import Xrefcheck.CLI (Options (..), addTraversalOptions, addVerifyOptions, defaultConfigPaths) import Xrefcheck.Config- (Config, Config' (..), ScannersConfig, ScannersConfig' (..), defConfig, normaliseConfigFilePaths,- overrideConfig)+ (Config, Config' (..), ScannersConfig (..), defConfig, normaliseConfigFilePaths, overrideConfig) import Xrefcheck.Core (Flavor (..)) import Xrefcheck.Progress (allowRewrite)-import Xrefcheck.Scan (FormatsSupport, scanRepo, specificFormatsSupport, ScanResult (..), ScanError (..))+import Xrefcheck.Scan+ (FormatsSupport, ScanError (..), ScanResult (..), scanRepo, specificFormatsSupport) import Xrefcheck.Scanners.Markdown (markdownSupport) import Xrefcheck.System (askWithinCI)+import Xrefcheck.Util import Xrefcheck.Verify (verifyErrors, verifyRepo) readConfig :: FilePath -> IO Config@@ -43,6 +46,8 @@ defaultAction :: Options -> IO () defaultAction Options{..} = do+ coloringSupported <- supportsPretty+ give (if coloringSupported then oColorMode else WithoutColors) $ do config <- case oConfigPath of Just configPath -> readConfig configPath Nothing -> do
src/Xrefcheck/Config.hs view
@@ -7,7 +7,7 @@ module Xrefcheck.Config where -import qualified Universum.Unsafe as Unsafe+import Universum.Unsafe qualified as Unsafe import Universum @@ -20,17 +20,17 @@ import Instances.TH.Lift () import Text.Regex.TDFA qualified as R import Text.Regex.TDFA.ByteString ()+import Text.Regex.TDFA.Common import Text.Regex.TDFA.Text qualified as R -import Time (KnownRatName, Second, Time(..), unitsP)+import Time (KnownRatName, Second, Time (..), unitsP) +import Xrefcheck.Config.Default import Xrefcheck.Core import Xrefcheck.Scan import Xrefcheck.Scanners.Markdown import Xrefcheck.System (RelGlobPattern, normaliseGlobPattern)-import Xrefcheck.Util (aesonConfigOption, postfixFields, (-:), Field)-import Xrefcheck.Config.Default-import Text.Regex.TDFA.Common+import Xrefcheck.Util (Field, aesonConfigOption, postfixFields, (-:)) -- | Type alias for Config' with all required fields. type Config = Config' Identity@@ -42,7 +42,7 @@ data Config' f = Config { cTraversal :: Field f (TraversalConfig' f) , cVerification :: Field f (VerifyConfig' f)- , cScanners :: Field f (ScannersConfig' f)+ , cScanners :: ScannersConfig } deriving stock (Generic) normaliseConfigFilePaths :: Config -> Config@@ -82,12 +82,9 @@ , vcNotScanned = map normaliseGlobPattern vcNotScanned } --- | Type alias for ScannersConfig' with all required fields.-type ScannersConfig = ScannersConfig' Identity- -- | Configs for all the supported scanners.-data ScannersConfig' f = ScannersConfig- { scMarkdown :: Field f (MarkdownConfig' f)+data ScannersConfig = ScannersConfig+ { scMarkdown :: MarkdownConfig } deriving stock (Generic) makeLensesWith postfixFields ''Config'@@ -211,11 +208,10 @@ = Config { cTraversal = TraversalConfig ignored , cVerification = maybe defVerification overrideVerify $ cVerification config- , cScanners = ScannersConfig (MarkdownConfig flavor)+ , cScanners = cScanners config } where- flavor = fromMaybe GitHub- $ mcFlavor =<< scMarkdown =<< cScanners config+ flavor = mcFlavor . scMarkdown $ cScanners config defTraversal = cTraversal $ defConfig flavor @@ -225,23 +221,18 @@ 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+ { vcAnchorSimilarityThreshold = overrideField vcAnchorSimilarityThreshold+ , vcExternalRefCheckTimeout = overrideField vcExternalRefCheckTimeout+ , vcVirtualFiles = overrideField vcVirtualFiles+ , vcNotScanned = overrideField vcNotScanned+ , vcIgnoreRefs = overrideField vcIgnoreRefs+ , vcIgnoreAuthFailures = overrideField vcIgnoreAuthFailures+ , vcDefaultRetryAfter = overrideField vcDefaultRetryAfter+ , vcMaxRetries = overrideField vcMaxRetries }+ where+ overrideField :: (forall f. VerifyConfig' f -> Field f a) -> a+ overrideField field = fromMaybe (field defVerification) $ field verifyConfig ----------------------------------------------------------- -- Yaml instances@@ -281,9 +272,6 @@ parseJSON = genericParseJSON aesonConfigOption instance FromJSON (VerifyConfig) where- parseJSON = genericParseJSON aesonConfigOption--instance FromJSON (ScannersConfig' Maybe) where parseJSON = genericParseJSON aesonConfigOption instance FromJSON (ScannersConfig) where
src/Xrefcheck/Config/Default.hs view
@@ -17,12 +17,7 @@ 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/**/*+ ignored: [] # Verification parameters. verification:
src/Xrefcheck/Core.hs view
@@ -18,17 +18,16 @@ import Data.Default (Default (..)) import Data.List qualified as L import Data.Map qualified as M+import Data.Reflection (Given) 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+import Xrefcheck.Progress+import Xrefcheck.Util ----------------------------------------------------------- -- Types@@ -64,10 +63,10 @@ newtype Position = Position (Maybe Text) deriving stock (Show, Eq, Generic) -instance Buildable Position where+instance Given ColorMode => Buildable Position where build (Position pos) = case pos of Nothing -> ""- Just p -> style Faint $ "at src:" <> build p+ Just p -> styleIfNeeded Faint $ "at src:" <> build p -- | Full info about a reference. data Reference = Reference@@ -123,8 +122,13 @@ instance Default FileInfo where def = diffToFileInfo mempty -newtype RepoInfo = RepoInfo (Map FilePath FileInfo)- deriving stock (Show)+-- | All tracked files and directories.+data RepoInfo = RepoInfo+ { riFiles :: Map FilePath (Maybe FileInfo)+ -- ^ Files from the repo with `FileInfo` attached to files that we can scan.+ , riDirectories :: Set FilePath+ -- ^ Tracked directories.+ } deriving stock (Show) ----------------------------------------------------------- -- Instances@@ -136,37 +140,47 @@ instance NFData Anchor instance NFData FileInfo -instance Buildable Reference where+instance Given ColorMode => Buildable Reference where build Reference{..} = nameF ("reference " +| paren (build loc) |+ " " +| rPos |+ "") $ blockListF [ "text: " <> show rName , "link: " <> build rLink- , "anchor: " <> build (rAnchor ?: style Faint "-")+ , "anchor: " <> build (rAnchor ?: styleIfNeeded Faint "-") ] where loc = locationType rLink -instance Buildable AnchorType where- build = style Faint . \case- HeaderAnchor l -> color Green ("header " <> toRoman l)- HandAnchor -> color Yellow "hand made"- BiblioAnchor -> color Cyan "biblio"+instance Given ColorMode => Buildable AnchorType where+ build = styleIfNeeded Faint . \case+ HeaderAnchor l -> colorIfNeeded Green ("header " <> headerLevelToRoman l)+ HandAnchor -> colorIfNeeded Yellow "hand made"+ BiblioAnchor -> colorIfNeeded Cyan "biblio"+ where+ headerLevelToRoman = \case+ 1 -> "I"+ 2 -> "II"+ 3 -> "III"+ 4 -> "IV"+ 5 -> "V"+ 6 -> "VI"+ n -> error "Bad header level: " <> show n -instance Buildable Anchor where+instance Given ColorMode => Buildable Anchor where build (Anchor t a p) = a |+ " (" +| t |+ ") " +| p |+ "" -instance Buildable FileInfo where+instance Given ColorMode => Buildable FileInfo where build FileInfo{..} = blockListF [ nameF "references" $ blockListF _fiReferences , nameF "anchors" $ blockListF _fiAnchors ] -instance Buildable RepoInfo where- build (RepoInfo m) = blockListF' "⮚" buildFileReport (M.toList m)+instance Given ColorMode => Buildable RepoInfo where+ build (RepoInfo m _) =+ blockListF' "⮚" buildFileReport (mapMaybe sequence $ M.toList m) where buildFileReport (name, info) = mconcat- [ color Cyan $ fromString name <> ":\n"+ [ colorIfNeeded Cyan $ fromString name <> ":\n" , build info , "\n" ]@@ -180,25 +194,25 @@ -- | Type of reference. data LocationType- = LocalLoc- -- ^ Reference on this file+ = CurrentFileLoc+ -- ^ Reference to this file, e.g. @[a](#header)@ | RelativeLoc- -- ^ Reference to a file relative to given one+ -- ^ Reference to a file relative to given one, e.g. @[b](folder/file#header)@ | AbsoluteLoc- -- ^ Reference to a file relative to the root+ -- ^ Reference to a file relative to the root, e.g. @[c](/folder/file#header)@ | ExternalLoc- -- ^ Reference to a file at outer site+ -- ^ Reference to a file at outer site, e.g @[d](http://www.google.com/doodles)@ | OtherLoc- -- ^ Entry not to be processed (e.g. "mailto:e-mail")+ -- ^ Entry not to be processed, e.g. @mailto:e-mail@ deriving stock (Eq, Show) -instance Buildable LocationType where+instance Given ColorMode => Buildable LocationType where build = \case- LocalLoc -> color Green "local"- RelativeLoc -> color Yellow "relative"- AbsoluteLoc -> color Blue "absolute"- ExternalLoc -> color Red "external"- OtherLoc -> ""+ CurrentFileLoc -> colorIfNeeded Green "current file"+ RelativeLoc -> colorIfNeeded Yellow "relative"+ AbsoluteLoc -> colorIfNeeded Blue "absolute"+ ExternalLoc -> colorIfNeeded Red "external"+ OtherLoc -> "" -- | Whether this is a link to external resource. isExternal :: LocationType -> Bool@@ -209,16 +223,16 @@ -- | Whether this is a link to repo-local resource. isLocal :: LocationType -> Bool isLocal = \case- LocalLoc -> True- RelativeLoc -> True- AbsoluteLoc -> True- ExternalLoc -> False- OtherLoc -> False+ CurrentFileLoc -> True+ RelativeLoc -> True+ AbsoluteLoc -> True+ ExternalLoc -> False+ OtherLoc -> False -- | Get type of reference. locationType :: Text -> LocationType locationType location = case toString location of- [] -> LocalLoc+ [] -> CurrentFileLoc PathSep : _ -> AbsoluteLoc '.' : PathSep : _ -> RelativeLoc '.' : '.' : PathSep : _ -> RelativeLoc@@ -314,7 +328,7 @@ where (extRefs, localRefs) = L.partition (isExternal . locationType . rLink) references -showAnalyseProgress :: VerifyMode -> Time Second -> VerifyProgress -> Text+showAnalyseProgress :: Given ColorMode => VerifyMode -> Time Second -> VerifyProgress -> Text showAnalyseProgress mode posixTime VerifyProgress{..} = mconcat . mconcat $ [ [ "Verifying " ]@@ -324,6 +338,7 @@ | shouldCheckExternal mode ] ] -reprintAnalyseProgress :: Rewrite -> VerifyMode -> Time Second -> VerifyProgress -> IO ()+reprintAnalyseProgress :: Given ColorMode =>+ Rewrite -> VerifyMode -> Time Second -> VerifyProgress -> IO () reprintAnalyseProgress rw mode posixTime p = putTextRewrite rw $ showAnalyseProgress mode posixTime p
src/Xrefcheck/Orphans.hs view
@@ -11,13 +11,13 @@ import Universum -import qualified Data.ByteString.Char8 as C+import Data.ByteString.Char8 qualified as C import Fmt (Buildable (..), unlinesF, (+|), (|+)) import Network.FTP.Client (FTPException (..), FTPMessage (..), FTPResponse (..), ResponseStatus (..)) import Text.URI (RText, unRText)-import URI.ByteString (URIParseError (..), SchemaError (..))+import URI.ByteString (SchemaError (..), URIParseError (..)) instance ToString (RText t) where toString = toString . unRText
src/Xrefcheck/Progress.hs view
@@ -30,9 +30,11 @@ import Universum import Data.Ratio ((%))-import System.Console.Pretty (Color (..), Style (..), color, style)-import Time (Second, Time, ms, sec, threadDelay, unTime, (-:-))+import Data.Reflection (Given)+import Time (Second, Time, sec, unTime, (-:-)) +import Xrefcheck.Util+ ----------------------------------------------------------- -- Task timestamp -----------------------------------------------------------@@ -126,12 +128,12 @@ else removeTaskTimestamp p -- | Visualise progress bar.-showProgress :: Text -> Int -> Color -> Time Second -> Progress Int -> Text+showProgress :: Given ColorMode => Text -> Int -> Color -> Time Second -> Progress Int -> Text showProgress name width col posixTime Progress{..} = mconcat- [ color col (name <> ": [")+ [ colorIfNeeded col (name <> ": [") , toText bar , timer- , color col "]"+ , colorIfNeeded col "]" , status ] where@@ -170,25 +172,25 @@ bar | pTotal == 0 = replicate width '-' | otherwise = mconcat- [ color Blue $ replicate errsF '■'- , color Red $ replicate errsU '■'- , color col $ replicate successful '■'- , color col $ replicate remaining ' '+ [ colorIfNeeded Blue $ replicate errsF '■'+ , colorIfNeeded Red $ replicate errsU '■'+ , colorIfNeeded col $ replicate successful '■'+ , colorIfNeeded col $ replicate remaining ' ' , " " ] timer = case pTaskTimestamp of Nothing -> "" Just TaskTimestamp{..} -> mconcat- [ color col "|"- , color Blue . show . timeSecondCeiling+ [ colorIfNeeded col "|"+ , colorIfNeeded Blue . show . timeSecondCeiling $ ttTimeToCompletion -:- (posixTime -:- ttStart) ] status = mconcat [ if pCurrent == pTotal && pErrorsFixable == 0 && pErrorsUnfixable == 0- then style Faint $ color White "✓"+ then styleIfNeeded Faint $ colorIfNeeded White "✓" else ""- , if pErrorsFixable /= 0 then color Blue "!" else ""- , if pErrorsUnfixable /= 0 then color Red "!" else ""+ , if pErrorsFixable /= 0 then colorIfNeeded Blue "!" else ""+ , if pErrorsUnfixable /= 0 then colorIfNeeded Red "!" else "" ] timeSecondCeiling :: Time Second -> Time Second@@ -225,8 +227,6 @@ erase (Rewrite RewriteCtx{..}) = liftIO $ do maxPrintedSize <- readIORef rMaxPrintedSize hPutStr stderr $ '\r' : replicate maxPrintedSize ' ' ++ "\r"- -- prevent our output to interleave with further outputs- threadDelay (ms 100) erase RewriteDisabled = pass -- | Return caret and print the given text.
src/Xrefcheck/Scan.hs view
@@ -13,6 +13,7 @@ , FormatsSupport , RepoInfo (..) , ScanError (..)+ , ScanErrorDescription (..) , ScanResult (..) , normaliseTraversalConfigFilePaths@@ -22,19 +23,20 @@ import Universum -import Data.Aeson(FromJSON (..), genericParseJSON)-import Data.Foldable qualified as F+import Data.Aeson (FromJSON (..), genericParseJSON)+import Data.List qualified as L import Data.Map qualified as M-import Fmt (Buildable (..), (+|), (|+), nameF)-import System.Console.Pretty (Pretty(..), Style (..))+import Data.Reflection (Given)+import Fmt (Buildable (..), nameF, (+|), (|+)) import System.Directory (doesDirectoryExist)-import System.Directory.Tree qualified as Tree-import System.FilePath (dropTrailingPathSeparator, takeDirectory, takeExtension, equalFilePath)+import System.FilePath+ (dropTrailingPathSeparator, equalFilePath, splitDirectories, takeDirectory, takeExtension, (</>))+import System.Process (cwd, readCreateProcess, shell) import Xrefcheck.Core import Xrefcheck.Progress-import Xrefcheck.System (readingSystem, RelGlobPattern, normaliseGlobPattern, matchesGlobPatterns)-import Xrefcheck.Util (aesonConfigOption, normaliseWithNoTrailing, Field)+import Xrefcheck.System (RelGlobPattern, matchesGlobPatterns, normaliseGlobPattern, readingSystem)+import Xrefcheck.Util -- | Type alias for TraversalConfig' with all required fields. type TraversalConfig = TraversalConfig' Identity@@ -71,15 +73,32 @@ data ScanError = ScanError { sePosition :: Position , seFile :: FilePath- , seDescription :: Text+ , seDescription :: ScanErrorDescription } deriving stock (Show, Eq) -instance Buildable ScanError where+instance Given ColorMode => Buildable ScanError where build ScanError{..} =- "In file " +| style Faint (style Bold seFile) |+ "\n"+ "In file " +| styleIfNeeded Faint (styleIfNeeded Bold seFile) |+ "\n" +| nameF ("scan error " +| sePosition |+ "") mempty |+ "\n⛀ " +| seDescription |+ "\n\n\n" +data ScanErrorDescription+ = LinkErr+ | FileErr+ | ParagraphErr Text+ | UnrecognisedErr Text+ deriving stock (Show, Eq)++instance Buildable ScanErrorDescription where+ build = \case+ LinkErr -> "Expected a LINK after \"ignore link\" annotation"+ FileErr -> "Annotation \"ignore file\" must be at the top of \+ \markdown or right after comments at the top"+ ParagraphErr txt -> "Expected a PARAGRAPH after \+ \\"ignore paragraph\" annotation, but found " +| txt |+ ""+ UnrecognisedErr txt -> "Unrecognised option \"" +| txt |+ "\" perhaps you meant \+ \<\"ignore link\"|\"ignore paragraph\"|\"ignore file\"> "+ specificFormatsSupport :: [([Extension], ScanAction)] -> FormatsSupport specificFormatsSupport formats = \ext -> M.lookup ext formatsMap where@@ -89,6 +108,31 @@ , extension <- extensions ] +-- | Process files that are tracked by git and not ignored by the config.+readDirectoryWith+ :: forall a. TraversalConfig+ -> (FilePath -> IO a)+ -> FilePath+ -> IO [(FilePath, a)]+readDirectoryWith config scanner root =+ traverse scanFile+ . filter (not . isIgnored)+ . fmap (location </>)+ . L.lines =<< readCreateProcess (shell "git ls-files"){cwd = Just root} ""+ where+ scanFile :: FilePath -> IO (FilePath, a)+ scanFile = sequence . (normaliseWithNoTrailing &&& scanner)++ isIgnored :: FilePath -> Bool+ isIgnored = matchesGlobPatterns root $ tcIgnored config++ -- Strip leading "." and trailing "/"+ location :: FilePath+ location =+ if root `equalFilePath` "."+ then ""+ else dropTrailingPathSeparator root+ scanRepo :: MonadIO m => Rewrite -> FormatsSupport -> TraversalConfig -> FilePath -> m ScanResult@@ -98,36 +142,33 @@ 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)+ (errs, fileInfos) <- liftIO+ $ (gatherScanErrs &&& gatherFileInfos)+ <$> readDirectoryWith config processFile root++ let dirs = fromList $ foldMap (getDirs . fst) fileInfos++ return . ScanResult errs $ RepoInfo (M.fromList fileInfos) dirs where+ isDirectory :: FilePath -> Bool isDirectory = readingSystem . doesDirectoryExist- gatherScanErrs = foldMap (snd . snd)- gatherFileInfos = map (bimap normaliseWithNoTrailing fst) + -- Get all directories from filepath.+ getDirs :: FilePath -> [FilePath]+ getDirs = scanl (</>) "" . splitDirectories . takeDirectory++ gatherScanErrs+ :: [(FilePath, Maybe (FileInfo, [ScanError]))]+ -> [ScanError]+ gatherScanErrs = fold . mapMaybe (fmap snd . snd)++ gatherFileInfos+ :: [(FilePath, Maybe (FileInfo, [ScanError]))]+ -> [(FilePath, Maybe FileInfo)]+ gatherFileInfos = map (second (fmap fst))++ processFile :: FilePath -> IO $ Maybe (FileInfo, [ScanError]) processFile file = do 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]-- 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+ forM mscanner ($ file)
src/Xrefcheck/Scanners/Markdown.hs view
@@ -8,9 +8,8 @@ -- | Markdown documents markdownScanner. module Xrefcheck.Scanners.Markdown- ( MarkdownConfig' (..)- , MarkdownConfig- , IgnoreMode (..)+ ( MarkdownConfig (..)+ , defGithubMdConfig , markdownScanner , markdownSupport@@ -20,7 +19,8 @@ import Universum -import CMarkGFM (Node (..), NodeType (..), PosInfo (..), commonmarkToNode)+import CMarkGFM (Node (..), NodeType (..), PosInfo (..), commonmarkToNode, optFootnotes)+import Control.Lens (_Just, makeLenses, makeLensesFor, (.=)) import Control.Monad.Trans.Writer.CPS (Writer, runWriter, tell) import Data.Aeson (FromJSON (..), genericParseJSON) import Data.ByteString.Lazy qualified as BSL@@ -35,16 +35,10 @@ import Xrefcheck.Scan import Xrefcheck.Util --- | Type alias for MarkdownConfig' with all required fields.-type MarkdownConfig = MarkdownConfig' Identity--data MarkdownConfig' f = MarkdownConfig- { mcFlavor :: Field f Flavor+data MarkdownConfig = MarkdownConfig+ { mcFlavor :: Flavor } deriving stock (Generic) -instance FromJSON (MarkdownConfig' Maybe) where- parseJSON = genericParseJSON aesonConfigOption- instance FromJSON (MarkdownConfig) where parseJSON = genericParseJSON aesonConfigOption @@ -79,31 +73,87 @@ nodeFlatten :: Node -> [NodeType] nodeFlatten (Node _pos ty subs) = ty : concatMap nodeFlatten subs + data IgnoreMode- = Link- | Paragraph- | File- | None+ = IMLink+ | IMParagraph+ | IMFile deriving stock (Eq) +-- | "ignore link" pragmas in different places behave slightly different,+-- so @IgnoreMode@ @Link@ is parametrized+data IgnoreLinkState+ = ExpectingLinkInParagraph+ -- ^ When ignore annotation is inside @PARAGRAPH@ node,+ -- we expect a link to ignore later in this paragraph.+ -- We raise scan error if we see this status after+ -- traversing subnodes of a @PARAGRAPH@ node.+ | ExpectingLinkInSubnodes+ -- ^ If ignore annotation is not inside @PARAGRAPH@, then we expect a link+ -- in subtree of next node. We raise scan error if we see this status+ -- after traversing childs of any node that is not an ignore annotation.+ | ParentExpectsLink+ -- ^ When we have `ExpectingLinkInSubnodes`, we traverse subtree of some node,+ -- and we should change `IgnoreLinkState`, because it's not a problem if+ -- our node's first child doesn't contain a link. So this status means that+ -- we won't throw errors if we don't find a link for now+ deriving stock (Eq)++data IgnoreModeState+ = IMSLink IgnoreLinkState+ | IMSParagraph+ | IMSFile+ deriving stock (Eq)+ -- | Bind `IgnoreMode` to its `PosInfo` so that we can tell where the -- corresponding annotation was declared.-data Ignore = Ignore IgnoreMode (Maybe PosInfo)+data Ignore = Ignore+ { _ignoreMode :: IgnoreModeState+ , _ignorePos :: Maybe PosInfo+ }+makeLensesFor [("_ignoreMode", "ignoreMode")] 'Ignore -type ScannerM a = StateT Ignore (Writer [ScanError]) a+data GetIgnoreMode+ = NotAnAnnotation+ | ValidMode IgnoreMode+ | InvalidMode Text+ deriving stock (Eq) --- | Empty `Ignore` state-ignoreNone :: Ignore-ignoreNone = Ignore None Nothing ++data ScannerState = ScannerState+ { _ssIgnore :: Maybe Ignore+ , _ssParentNodeType :: Maybe NodeType+ -- ^ @cataNodeWithParentNodeInfo@ allows to get a @NodeType@ of parent node from this field+ }+makeLenses ''ScannerState++initialScannerState :: ScannerState+initialScannerState = ScannerState+ { _ssIgnore = Nothing+ , _ssParentNodeType = Nothing+ }++type ScannerM a = StateT ScannerState (Writer [ScanError]) a+ -- | 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) --- | Remove nodes with accordance with global `MarkdownConfig` and local--- overrides.+-- | Sets correct @_ssParentNodeType@ before running scanner on each node+cataNodeWithParentNodeInfo+ :: (Maybe PosInfo -> NodeType -> [ScannerM a] -> ScannerM a)+ -> Node+ -> ScannerM a+cataNodeWithParentNodeInfo f node = cataNode f' node+ where+ f' pos ty childScanners = f pos ty $+ map (ssParentNodeType .= Just ty >>) childScanners++-- | Find ignore annotations (ignore paragraph and ignore link)+-- and remove nodes that should be ignored removeIgnored :: FilePath -> Node -> Writer [ScanError] Node-removeIgnored fp = withIgnoreMode . cataNode remove+removeIgnored fp = withIgnoreMode . cataNodeWithParentNodeInfo remove where remove :: Maybe PosInfo@@ -111,59 +161,79 @@ -> [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+ scan <- use ssIgnore >>= \case+ -- When no `Ignore` state is set check next node for annotation,+ -- if found then set it as new `IgnoreMode` otherwise skip node.+ Nothing -> handleIgnoreMode pos ty subs $ getIgnoreMode node+ Just (Ignore mode modePos) ->+ case (mode, ty) of+ -- We expect to find a paragraph immediately after the+ -- `ignore paragraph` annotanion. If the paragraph is not+ -- found we should report an error.+ (IMSParagraph, PARAGRAPH) -> (ssIgnore .= Nothing) $> defNode+ (IMSParagraph, x) -> do+ lift . tell . makeError modePos fp . ParagraphErr $ prettyType x+ ssIgnore .= Nothing+ Node pos ty <$> sequence subs - -- 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+ -- 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.+ (IMSFile, _) -> do+ lift . tell $ makeError modePos fp FileErr+ ssIgnore .= Nothing+ Node pos ty <$> sequence subs - -- 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+ (IMSLink _, LINK {}) -> do+ ssIgnore .= Nothing+ return defNode+ (IMSLink ignoreLinkState, _) -> do+ when (ignoreLinkState == ExpectingLinkInSubnodes) $+ ssIgnore . _Just . ignoreMode .= IMSLink ParentExpectsLink+ node' <- Node pos ty <$> sequence subs+ when (ignoreLinkState == ExpectingLinkInSubnodes) $ do+ currentIgnore <- use ssIgnore+ case currentIgnore of+ Just (Ignore {_ignoreMode = IMSLink ParentExpectsLink}) -> do+ lift $ tell $ makeError modePos fp LinkErr+ ssIgnore .= Nothing+ _ -> pass+ return node' - -- 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+ when (ty == PARAGRAPH) $ use ssIgnore >>= \case+ Just (Ignore (IMSLink ExpectingLinkInParagraph) pragmaPos) ->+ lift $ tell $ makeError pragmaPos fp LinkErr+ _ -> pass - handleMode- :: Node- -> IgnoreMode+ return scan++ handleIgnoreMode+ :: Maybe PosInfo+ -> NodeType+ -> [ScannerM Node]+ -> GetIgnoreMode -> 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+ handleIgnoreMode pos nodeType subs = \case+ ValidMode mode -> do+ ignoreModeState <- case mode of+ IMLink -> use ssParentNodeType <&> IMSLink . \case+ Just PARAGRAPH -> ExpectingLinkInParagraph+ _ -> ExpectingLinkInSubnodes + IMParagraph -> pure IMSParagraph++ IMFile -> pure IMSFile++ (ssIgnore .= Just (Ignore ignoreModeState correctPos)) $> defNode+ InvalidMode msg -> do+ lift . tell $ makeError correctPos fp $ UnrecognisedErr msg+ (ssIgnore .= Nothing) $> defNode+ NotAnAnnotation -> Node pos nodeType <$> sequence subs+ where+ correctPos = getPosition $ Node pos nodeType []+ prettyType :: NodeType -> Text prettyType ty = let mType = safeHead $ words $ show ty@@ -172,21 +242,21 @@ withIgnoreMode :: ScannerM Node -> Writer [ScanError] Node- withIgnoreMode action = action `runStateT` ignoreNone >>= \case- -- We expect `IgnoreMode` to be `None` when we reach EOF,+ withIgnoreMode action = action `runStateT` initialScannerState >>= \case+ -- We expect `Ignore` state to be `Nothing` when we reach EOF, -- otherwise that means there was an annotation that didn't match -- any node, so we have to report that.- (node, Ignore None _) -> pure node- (node, (Ignore mode pos))- | mode == Paragraph -> do- tell $ makeError pos fp mode "EOF"+ (node, ScannerState {_ssIgnore = Just (Ignore mode pos)}) -> case mode of+ IMSParagraph -> do+ tell . makeError pos fp $ ParagraphErr "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 ""+ IMSLink _ -> do+ tell $ makeError pos fp LinkErr pure node-+ IMSFile -> do+ tell $ makeError pos fp FileErr+ pure node+ (node, _) -> pure node -- | Custom `foldMap` for source tree. foldNode :: (Monoid a, Monad m) => (Node -> m a) -> Node -> m a@@ -271,7 +341,7 @@ isComment = isJust . getCommentContent isIgnoreFile :: Node -> Bool- isIgnoreFile = (Just File ==) . getIgnoreMode+ isIgnoreFile = (ValidMode IMFile ==) . getIgnoreMode defNode :: Node defNode = Node Nothing DOCUMENT [] -- hard-coded default Node@@ -279,37 +349,9 @@ makeError :: Maybe PosInfo -> FilePath- -> IgnoreMode- -> Text+ -> ScanErrorDescription -> [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\"> "- ]+makeError pos fp errDescription = one $ ScanError (toPosition pos) fp errDescription getCommentContent :: Node -> Maybe Text getCommentContent node = do@@ -340,23 +382,23 @@ 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+getIgnoreMode :: Node -> GetIgnoreMode+getIgnoreMode node = maybe NotAnAnnotation (textToMode . words) (getXrefcheckContent node) -textToMode :: [Text] -> Maybe IgnoreMode+textToMode :: [Text] -> GetIgnoreMode textToMode ("ignore" : [x])- | x == "link" = return Link- | x == "paragraph" = return Paragraph- | x == "file" = return File- | otherwise = return None-textToMode _ = Nothing+ | x == "link" = ValidMode IMLink+ | x == "paragraph" = ValidMode IMParagraph+ | x == "file" = ValidMode IMFile+ | otherwise = InvalidMode x+textToMode _ = NotAnAnnotation parseFileInfo :: MarkdownConfig -> FilePath -> LT.Text -> (FileInfo, [ScanError]) parseFileInfo config fp input = runWriter $ flip runReaderT config $ nodeExtractInfo fp- $ commonmarkToNode [] []+ $ commonmarkToNode [optFootnotes] [] $ toStrict input markdownScanner :: MarkdownConfig -> ScanAction
src/Xrefcheck/System.hs view
@@ -6,7 +6,8 @@ module Xrefcheck.System ( readingSystem , askWithinCI- , RelGlobPattern (..)+ , RelGlobPattern+ , mkGlobPattern , normaliseGlobPattern , bindGlobPattern , matchesGlobPatterns@@ -16,12 +17,13 @@ import Data.Aeson (FromJSON (..), withText) import Data.Char qualified as C+import Data.Coerce (coerce) import GHC.IO.Unsafe (unsafePerformIO) import System.Directory (canonicalizePath) import System.Environment (lookupEnv)-import System.FilePath ((</>))+import System.FilePath (isRelative, (</>))+import System.FilePath.Glob (CompOptions (errorRecovery)) import System.FilePath.Glob qualified as Glob-import Data.Coerce (coerce) import Xrefcheck.Util (normaliseWithNoTrailing) -- | We can quite safely treat surrounding filesystem as frozen,@@ -37,9 +39,26 @@ Just (map C.toLower -> "true") -> True _ -> False --- | Glob pattern relative to repository root.+-- | Glob pattern relative to repository root. Should be created via @mkGlobPattern@ newtype RelGlobPattern = RelGlobPattern FilePath +mkGlobPattern :: ToString s => s -> Either String RelGlobPattern+mkGlobPattern path = do+ let spath = toString path+ unless (isRelative spath) $ Left $+ "Expected a relative glob pattern, but got " <> spath+ -- Checking correctness of glob, e.g. "a[b" is incorrect+ case Glob.tryCompileWith globCompileOptions spath of+ Right _ -> return (RelGlobPattern spath)+ Left err -> Left+ $ "Glob pattern compilation failed.\n"+ <> "Error message is:\n"+ <> err+ <> "\nThe syntax for glob patterns is described here:\n"+ <> "https://hackage.haskell.org/package/Glob/docs/System-FilePath-Glob.html#v:compile"+ <> "\nSpecial characters in file names can be escaped using square brackets"+ <> ", e.g. <a> -> [<]a[>]."+ normaliseGlobPattern :: RelGlobPattern -> RelGlobPattern normaliseGlobPattern = RelGlobPattern . normaliseWithNoTrailing . coerce @@ -62,13 +81,9 @@ ] 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" $+ either fail pure . mkGlobPattern -- | Glob compilation options we use. globCompileOptions :: Glob.CompOptions-globCompileOptions = Glob.compDefault+globCompileOptions = Glob.compDefault{errorRecovery = False}
src/Xrefcheck/Util.hs view
@@ -3,11 +3,8 @@ - SPDX-License-Identifier: MPL-2.0 -} -{-# OPTIONS_GHC -fno-warn-orphans #-}- module Xrefcheck.Util ( Field- , nameF' , paren , postfixFields , (-:)@@ -15,6 +12,7 @@ , normaliseWithNoTrailing , posixTimeToTimeSecond , utcTimeToTimeSecond+ , module Xrefcheck.Util.Colorize ) where import Universum@@ -27,17 +25,11 @@ 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 Fmt (Builder) 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 = nameF (style Faint a)+import Xrefcheck.Util.Colorize paren :: Builder -> Builder paren a@@ -53,7 +45,7 @@ -- | Options that we use to derive JSON instances for config types. aesonConfigOption :: Aeson.Options-aesonConfigOption = aesonPrefix camelCase+aesonConfigOption = (aesonPrefix camelCase){Aeson.rejectUnknownFields = True} -- | Config fields that may be abscent. type family Field f a where
+ src/Xrefcheck/Util/Colorize.hs view
@@ -0,0 +1,46 @@+{- SPDX-FileCopyrightText: 2018-2019 Serokell <https://serokell.io>+ -+ - SPDX-License-Identifier: MPL-2.0+ -}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++module Xrefcheck.Util.Colorize+ ( ColorMode(..)+ , Color(..)+ , Style(..)+ , colorizeIfNeeded+ , colorIfNeeded+ , styleIfNeeded+ ) where++import Universum++import Data.Reflection (Given (..))+import Fmt (Buildable (build), Builder, fmt)+import System.Console.Pretty (Color (..), Pretty (..), Section, Style (..))++{-# HLINT ignore "Avoid style function that ignore ColorMode" #-}+{-# HLINT ignore "Avoid color function that ignore ColorMode"#-}+{-# HLINT ignore "Avoid colorize function that ignore ColorMode"#-}++data ColorMode = WithColors | WithoutColors++instance Pretty Builder where+ colorize s c = build @Text . colorize s c . fmt+ style s = build @Text . style s . fmt++colorIfNeeded :: (Pretty a, Given ColorMode) => Color -> a -> a+colorIfNeeded = case given of+ WithColors -> color+ WithoutColors -> const id++styleIfNeeded :: (Pretty a, Given ColorMode) => Style -> a -> a+styleIfNeeded = case given of+ WithColors -> style+ WithoutColors -> const id++colorizeIfNeeded :: (Pretty a, Given ColorMode) => Section -> Color -> a -> a+colorizeIfNeeded section = case given of+ WithColors -> colorize section+ WithoutColors -> const id
src/Xrefcheck/Verify.hs view
@@ -33,17 +33,19 @@ import Universum -import Control.Concurrent.Async (wait, withAsync)+import Control.Concurrent.Async (async, wait, withAsync) import Control.Exception (throwIO)+import Control.Monad.Catch (handleJust) import Control.Monad.Except (MonadError (..)) import Data.ByteString qualified as BS import Data.List qualified as L import Data.Map qualified as M+import Data.Reflection (Given) import Data.Text.Metrics (damerauLevenshteinNorm) import Data.Time (UTCTime, defaultTimeLocale, formatTime, readPTime, rfc822DateFormat) import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Traversable (for)-import Fmt (Buildable (..), blockListF', listF, maybeF, nameF, (+|), (|+), unlinesF, indentF)+import Fmt (Buildable (..), blockListF', indentF, listF, maybeF, nameF, unlinesF, (+|), (|+)) import GHC.Exts qualified as Exts import GHC.Read (Read (readPrec)) import Network.FTP.Client@@ -55,15 +57,13 @@ 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 (doesDirectoryExist, doesFileExist)-import System.FilePath (takeDirectory, (</>), normalise)+import System.FilePath+ (equalFilePath, joinPath, makeRelative, normalise, splitDirectories, takeDirectory, (</>)) import Text.ParserCombinators.ReadPrec qualified as ReadPrec (lift) import Text.Regex.TDFA.Text (Regex, regexec)-import Text.URI (Authority (..), URI (..), mkURIBs, ParseExceptionBs)+import Text.URI (Authority (..), ParseExceptionBs, URI (..), mkURIBs) 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@@ -111,14 +111,15 @@ , wrlItem :: a } -instance Buildable a => Buildable (WithReferenceLoc a) where+instance (Given ColorMode, Buildable a) => Buildable (WithReferenceLoc a) where build WithReferenceLoc{..} =- "In file " +| style Faint (style Bold wrlFile) |+ "\nbad "+ "In file " +| styleIfNeeded Faint (styleIfNeeded Bold wrlFile) |+ "\nbad " +| wrlReference |+ "\n" +| wrlItem |+ "\n\n" data VerifyError = LocalFileDoesNotExist FilePath+ | LocalFileOutsideRepo FilePath | AnchorDoesNotExist Text [Anchor] | AmbiguousAnchorRef FilePath Text (NonEmpty Anchor) | ExternalResourceInvalidUri URIBS.URIParseError@@ -133,11 +134,14 @@ | ExternalResourceSomeError Text deriving stock (Show, Eq) -instance Buildable VerifyError where+instance Given ColorMode => Buildable VerifyError where build = \case LocalFileDoesNotExist file -> "⛀ File does not exist:\n " +| file |+ "\n" + LocalFileOutsideRepo file ->+ "⛀ Link targets a local file outside repository:\n " +| file |+ "\n"+ AnchorDoesNotExist anchor similar -> "⛀ Anchor '" +| anchor |+ "' is not present" +| anchorHints similar@@ -244,7 +248,8 @@ go acc _ [] = for acc wait <&> reverse verifyRepo- :: Rewrite+ :: Given ColorMode+ => Rewrite -> VerifyConfig -> VerifyMode -> FilePath@@ -255,22 +260,26 @@ config@VerifyConfig{..} mode root- repoInfo'@(RepoInfo repoInfo)+ repoInfo'@(RepoInfo files _) = do let toScan = do- (file, fileInfo) <- M.toList repoInfo+ (file, fileInfo) <- M.toList files guard . not $ matchesGlobPatterns root vcNotScanned file- ref <- _fiReferences fileInfo- return (file, ref)+ case fileInfo of+ Just fi -> do+ ref <- _fiReferences fi+ return (file, ref)+ Nothing -> empty -- no support for such file, can do nothing progressRef <- newIORef $ initVerifyProgress (map snd toScan) - accumulated <- withAsync (printer progressRef) $ \_ ->+ accumulated <- loopAsyncUntil (printer progressRef) do forConcurrentlyCaching toScan ifExternalThenCache $ \(file, ref) -> verifyReference config mode progressRef repoInfo' root file ref return $ fold accumulated where- printer progressRef = forever $ do+ printer :: IORef VerifyProgress -> IO ()+ printer progressRef = do posixTime <- getPOSIXTime <&> posixTimeToTimeSecond progress <- atomicModifyIORef' progressRef $ \VerifyProgress{..} -> let prog = VerifyProgress{ vrExternal =@@ -279,8 +288,10 @@ } in (prog, prog) reprintAnalyseProgress rw mode posixTime progress+ -- Slight pause so we're not refreshing the progress bar more often than needed. threadDelay (ms 100) + ifExternalThenCache :: (a, Reference) -> NeedsCaching Text ifExternalThenCache (_, Reference{..}) = case locationType rLink of ExternalLoc -> CacheUnderKey rLink _ -> NoCaching@@ -304,7 +315,7 @@ config@VerifyConfig{..} mode progressRef- (RepoInfo repoInfo)+ (RepoInfo files dirs) root fileWithReference ref@Reference{..}@@ -312,13 +323,13 @@ 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+ CurrentFileLoc -> checkRef rAnchor fileWithReference+ RelativeLoc -> checkRef rAnchor+ (normalise $ takeDirectory fileWithReference+ </> toString (canonizeLocalRef rLink))+ AbsoluteLoc -> checkRef rAnchor (root <> toString rLink)+ ExternalLoc -> checkExternalResource config rLink+ OtherLoc -> verifying pass else return mempty where retryVerification@@ -403,22 +414,65 @@ 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)+ isVirtual = matchesGlobPatterns root vcVirtualFiles - checkReferredFileExists file = do- let fileExists = readingSystem $ doesFileExist file- let dirExists = readingSystem $ doesDirectoryExist file+ checkRef mAnchor referredFile = verifying $+ unless (isVirtual referredFile) do+ checkReferredFileIsInsideRepo referredFile+ checkReferredFileExists referredFile+ case lookupFilePath referredFile $ M.toList files of+ Nothing -> pass -- no support for such file, can do nothing+ Just referredFileInfo -> whenJust mAnchor $+ checkAnchor referredFile (_fiAnchors referredFileInfo) - let isVirtual = matchesGlobPatterns root vcVirtualFiles file+ lookupFilePath :: FilePath -> [(FilePath, Maybe FileInfo)] -> Maybe FileInfo+ lookupFilePath fp = snd <=< find (equalFilePath (expandIndirections fp) . fst) - unless (fileExists || dirExists || isVirtual) $+ -- expands ".." and "."+ -- expandIndirections "a/b/../c" = "a/c"+ -- expandIndirections "a/b/c/../../d" = "a/d"+ -- expandIndirections "../../a" = "../../a"+ -- expandIndirections "a/./b" = "a/b"+ -- expandIndirections "a/b/./../c" = "a/c"+ expandIndirections :: FilePath -> FilePath+ expandIndirections = joinPath . reverse . expand 0 . reverse . splitDirectories+ where+ expand :: Int -> [FilePath] -> [FilePath]+ expand acc ("..":xs) = expand (acc+1) xs+ expand acc (".":xs) = expand acc xs+ expand 0 (x:xs) = x : expand 0 xs+ expand acc (_:xs) = expand (acc-1) xs+ expand acc [] = replicate acc ".."++ checkReferredFileIsInsideRepo file = unless+ (noNegativeNesting $ makeRelative root file) $+ throwError (LocalFileOutsideRepo file)+ where+ -- checks that relative filepath fully belongs to the root directory+ -- noNegativeNesting "a/../b" = True+ -- noNegativeNesting "a/../../b" = False+ noNegativeNesting path = all (>= 0) $ scanl+ (\n dir -> n + nestingChange dir)+ (0 :: Integer)+ $ splitDirectories path++ nestingChange ".." = -1+ nestingChange "." = 0+ nestingChange _ = 1++ checkReferredFileExists file = do+ unless (fileExists || dirExists) $ throwError (LocalFileDoesNotExist file)+ where+ matchesFilePath :: FilePath -> Bool+ matchesFilePath = equalFilePath $ expandIndirections file + fileExists :: Bool+ fileExists = any matchesFilePath $ M.keys files++ dirExists :: Bool+ dirExists = any matchesFilePath dirs+ checkAnchor file fileAnchors anchor = do checkAnchorReferenceAmbiguity file fileAnchors anchor checkDeduplicatedAnchorReference file fileAnchors anchor@@ -621,3 +675,28 @@ pure () where handler = if secure then withFTPS else withFTP++----------------------------------------------------------------------------+-- Helpers+----------------------------------------------------------------------------++-- | @loopAsyncUntil ma mb@ will continually run @ma@ until @mb@ throws an exception or returns.+-- Once it does, it'll wait for @ma@ to finish running one last time and then return.+--+-- See #163 to read more on why it's important to let @ma@ finish cleanly.+-- * https://github.com/serokell/xrefcheck/issues/162+-- * https://github.com/serokell/xrefcheck/pull/163+loopAsyncUntil :: forall a b. IO a -> IO b -> IO b+loopAsyncUntil loopingAction action =+ mask $ \restore -> do+ shouldLoop <- newIORef True+ loopingActionAsync <- async $ restore $ loopingAction' shouldLoop+ restore action `finally` do+ writeIORef shouldLoop False+ wait loopingActionAsync+ where+ loopingAction' :: IORef Bool -> IO ()+ loopingAction' shouldLoop = do+ whenM (readIORef shouldLoop) do+ void loopingAction+ loopingAction' shouldLoop
tests/Main.hs view
@@ -1,12 +1,15 @@-{- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>- -- - SPDX-License-Identifier: MPL-2.0- -}+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io>+--+-- SPDX-License-Identifier: MPL-2.0 +module Main+ ( main+ ) where+ import Universum -import Spec (spec)-import Test.Hspec (hspec)+import Test.Tasty+import Tree (tests) main :: IO ()-main = hspec spec+main = tests >>= defaultMain
− tests/Spec.hs
@@ -1,6 +0,0 @@-{- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>- -- - SPDX-License-Identifier: MPL-2.0- -}--{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
tests/Test/Xrefcheck/AnchorsInHeadersSpec.hs view
@@ -7,21 +7,23 @@ import Universum -import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=)) -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"]+import Xrefcheck.Core - 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+test_anchorsInHeaders :: TestTree+test_anchorsInHeaders = testGroup "Anchors in headers"+ [ testCase "Check if anchors in headers are recognized" $ do+ (fi, errs) <- parse GitHub "tests/markdowns/without-annotations/anchors_in_headers.md"+ getAnchors fi @?= ["some-stuff", "stuff-section"]+ errs @?= []+ , testCase "Check if anchors with id attributes are recognized" $ do+ (fi, errs) <- parse GitHub "tests/markdowns/without-annotations/anchors_in_headers_with_id_attribute.md"+ getAnchors fi @?= ["some-stuff-with-id-attribute", "stuff-section-with-id-attribute"]+ errs @?= []+ ]+ where+ getAnchors :: FileInfo -> [Text]+ getAnchors fi = map aName $ fi ^. fiAnchors
tests/Test/Xrefcheck/AnchorsSpec.hs view
@@ -3,37 +3,37 @@ - SPDX-License-Identifier: MPL-2.0 -} -module Test.Xrefcheck.AnchorsSpec (spec) where+module Test.Xrefcheck.AnchorsSpec (test_anchors) where import Universum -import Test.Hspec (Spec, describe, it, shouldBe)-import Test.QuickCheck ((===))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=)) import Test.Xrefcheck.Util import Xrefcheck.Core -checkHeaderConversions- :: HasCallStack- => Flavor -> [(Text, Text)] -> Spec+checkHeaderConversions :: Flavor -> [(Text, Text)] -> TestTree checkHeaderConversions fl suites =- 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"- ]+ testGroup (show fl) $+ [testCase (show a <> " == " <> show b) $ headerToAnchor fl a @?= b | (a,b) <- suites]+ +++ [ testCase "Non-stripped header name should be stripped" $ do+ (fi, errs) <- parse fl "tests/markdowns/without-annotations/non_stripped_spaces.md"+ getAnchors fi @?= [ case fl of GitHub -> "header--with-leading-spaces"+ GitLab -> "header-with-leading-spaces"+ , "edge-case"+ ]+ errs @?= []+ ] where getAnchors :: FileInfo -> [Text] getAnchors fi = map aName $ fi ^. fiAnchors -spec :: Spec-spec = do- describe "Header-to-anchor conversion" $ do- checkHeaderConversions GitHub+test_anchors :: TestTree+test_anchors = do+ testGroup "Header-to-anchor conversion"+ [ checkHeaderConversions GitHub [ ( "Some header" , "some-header" )@@ -92,8 +92,7 @@ , "white_check_mark-checklist-for-your-pull-request" ) ]-- checkHeaderConversions GitLab+ , checkHeaderConversions GitLab [ ( "a # b" , "a-b" )@@ -134,3 +133,4 @@ , "white_check_mark-checklist-for-your-pull-request" ) ]+ ]
tests/Test/Xrefcheck/ConfigSpec.hs view
@@ -11,64 +11,80 @@ import Control.Exception qualified as E import Data.ByteString qualified as BS+import Data.List (isInfixOf)+import Data.Yaml (ParseException (..), decodeEither') import Network.HTTP.Types (Status (..))-import Test.Hspec (Spec, before, describe, it, shouldBe)-import Test.Hspec.Expectations (expectationFailure)-import Test.QuickCheck (ioProperty, once)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))+import Test.Tasty.QuickCheck (ioProperty, testProperty) + 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" $- forM_ allFlavors $ \flavor ->- it (show flavor) $- once . ioProperty $ evaluateWHNF_ @_ @Config (defConfig flavor)+test_config :: [TestTree]+test_config =+ [ testGroup "Default config is valid" [+ testProperty (show flavor) $+ ioProperty $ evaluateWHNF_ @_ @Config (defConfig flavor)+ | flavor <- allFlavors] - describe "Filled default config matches the expected format" $- before (BS.readFile "tests/configs/github-config.yaml") $- -- The config we match against can be regenerated with- -- stack exec xrefcheck -- dump-config -t GitHub -o tests/configs/github-config.yaml- it "Config matches" $- \config ->- 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"+ , testGroup "Filled default config matches the expected format"+ -- The config we match against can be regenerated with+ -- stack exec xrefcheck -- dump-config -t GitHub -o tests/configs/github-config.yaml+ [ testCase "Config matches" $ do+ config <- BS.readFile "tests/configs/github-config.yaml"+ when (config /= defConfigText GitHub) $+ assertFailure $ toString $ unwords+ [ "Config does not match the expected format."+ , "Run"+ , "`stack exec xrefcheck -- dump-config -t GitHub -o tests/configs/github-config.yaml`"+ , "and verify changes"+ ]+ ]+ , testGroup "`ignoreAuthFailures` working as expected" $+ let config = (cVerification $ defConfig GitHub) { vcIgnoreRefs = [] }+ in [ testCase "when True - assume 401 status is valid" $+ checkLinkWithServer (config { vcIgnoreAuthFailures = True })+ "http://127.0.0.1:3000/401" $ VerifyResult []++ , testCase "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" } ] - describe "`ignoreAuthFailures` working as expected" $ do- let config = (cVerification $ defConfig GitHub) { vcIgnoreRefs = [] }+ , testCase "when True - assume 403 status is valid" $+ checkLinkWithServer (config { vcIgnoreAuthFailures = True })+ "http://127.0.0.1:3000/403" $ VerifyResult [] - it "when True - assume 401 status is valid" $- checkLinkWithServer (config { vcIgnoreAuthFailures = True })- "http://127.0.0.1:3000/401" $ VerifyResult []+ , testCase "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" }+ ]+ ]+ , testGroup "Config parser reject input with unknown fields"+ [ testCase "throws error with useful messages" $ do+ case decodeEither' @Config (defConfigText GitHub <> "strangeField: []") of+ Left (AesonException str) ->+ if "unknown fields: [\"strangeField\"]" `isInfixOf` str+ then pure ()+ else assertFailure $ "Bad error message: " <> str+ _ -> assertFailure "Config parser accepted config with unknown field"+ ]+ ] - 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+ result @?= expectation
tests/Test/Xrefcheck/IgnoreAnnotationsSpec.hs view
@@ -8,45 +8,55 @@ import Universum import CMarkGFM (PosInfo (..))-import Test.Hspec (Spec, describe, it, shouldBe, shouldReturn)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=)) 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 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` []+test_ignoreAnnotations :: [TestTree]+test_ignoreAnnotations =+ [ testGroup "Parsing failures"+ [ testCase "Check if broken link annotation produce error" do+ let file = "tests/markdowns/with-annotations/no_link.md"+ errs <- getErrs file+ errs @?= makeError (Just $ PosInfo 7 1 7 31) file LinkErr+ , testCase "Check if broken paragraph annotation produce error" do+ let file = "tests/markdowns/with-annotations/no_paragraph.md"+ errs <- getErrs file+ errs @?= makeError (Just $ PosInfo 7 1 7 35) file (ParagraphErr "HEADING")+ , testCase "Check if broken ignore file annotation produce error" do+ let file = "tests/markdowns/with-annotations/unexpected_ignore_file.md"+ errs <- getErrs file+ errs @?= makeError (Just $ PosInfo 9 1 9 30) file FileErr+ , testCase "Check if broken unrecognised annotation produce error" do+ let file = "tests/markdowns/with-annotations/unrecognised_option.md"+ errs <- getErrs file+ errs @?= makeError (Just $ PosInfo 7 1 7 46) file (UnrecognisedErr "unrecognised-option")+ ]+ , testGroup "\"ignore link\" mode"+ [ testCase "Check \"ignore link\" performance" $ do+ let file = "tests/markdowns/with-annotations/ignore_link.md"+ (fi, errs) <- parse GitHub file+ getRefs fi @?=+ ["team", "team", "team", "hire-us", "how-we-work", "privacy", "link2", "link2", "link3"]+ errs @?= makeError (Just $ PosInfo 42 1 42 31) file LinkErr+ ]+ , testGroup "\"ignore paragraph\" mode"+ [ testCase "Check \"ignore paragraph\" performance" $ do+ (fi, errs) <- parse GitHub "tests/markdowns/with-annotations/ignore_paragraph.md"+ getRefs fi @?= ["blog", "contacts"]+ errs @?= []+ ]+ , testGroup "\"ignore file\" mode"+ [ testCase "Check \"ignore file\" performance" $ do+ (fi, errs) <- parse GitHub "tests/markdowns/with-annotations/ignore_file.md"+ getRefs fi @?= []+ errs @?= []+ ]+ ] where getRefs :: FileInfo -> [Text] getRefs fi = map rName $ fi ^. fiReferences
tests/Test/Xrefcheck/IgnoreRegexSpec.hs view
@@ -7,34 +7,37 @@ import Universum +import Data.Reflection (give) import Data.Yaml (decodeEither')-import Test.HUnit (assertFailure)-import Test.Hspec (Spec, describe, it)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase) import Text.Regex.TDFA (Regex) import Xrefcheck.Config import Xrefcheck.Core import Xrefcheck.Progress (allowRewrite)-import Xrefcheck.Scan (scanRepo, specificFormatsSupport, ScanResult (..))+import Xrefcheck.Scan (ScanResult (..), scanRepo, specificFormatsSupport) import Xrefcheck.Scanners.Markdown+import Xrefcheck.Util (ColorMode (WithoutColors)) 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+test_ignoreRegex :: TestTree+test_ignoreRegex = give WithoutColors $+ let root = "tests/markdowns/without-annotations"+ showProgressBar = False+ formats = specificFormatsSupport [markdownSupport defGithubMdConfig]+ verifyMode = ExternalOnlyMode - let linksTxt =- [ "https://bad.((external.)?)reference(/?)"- , "https://bad.reference.(org|com)"- ]- let regexs = linksToRegexs linksTxt- let config = setIgnoreRefs regexs (defConfig GitHub)+ linksTxt =+ [ "https://bad.((external.)?)reference(/?)"+ , "https://bad.reference.(org|com)"+ ]+ regexs = linksToRegexs linksTxt+ config = setIgnoreRefs regexs (defConfig GitHub) - it "Check that only not matched links are verified" $ do++ in testGroup "Regular expressions performance"+ [ testCase "Check that only not matched links are verified" $ do scanResult <- allowRewrite showProgressBar $ \rw -> scanRepo rw formats (config ^. cTraversalL) root @@ -69,6 +72,7 @@ assertFailure $ "Link \"" <> show link <> "\" is not considered as broken but it is (and shouldn't be ignored)"+ ] where pickBrokenLinks :: VerifyResult (WithReferenceLoc VerifyError) -> [Text]
tests/Test/Xrefcheck/LocalSpec.hs view
@@ -7,19 +7,19 @@ import Universum -import Test.Hspec (Spec, describe, it)-import Test.QuickCheck ((===))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=)) import Xrefcheck.Core (canonizeLocalRef) -spec :: Spec-spec = do- describe "Local refs canonizing" $ do- it "Strips ./" $- canonizeLocalRef "./AnchorsSpec.hs" === "AnchorsSpec.hs"+test_local_refs_canonizing :: TestTree+test_local_refs_canonizing = testGroup "Local refs canonizing" $+ [ testCase "Strips ./" $+ canonizeLocalRef "./AnchorsSpec.hs" @?= "AnchorsSpec.hs" - it "Strips ././" $- canonizeLocalRef "././AnchorsSpec.hs" === "AnchorsSpec.hs"+ , testCase "Strips ././" $+ canonizeLocalRef "././AnchorsSpec.hs" @?= "AnchorsSpec.hs" - it "Leaves plain other intact" $- canonizeLocalRef "../AnchorsSpec.hs" === "../AnchorsSpec.hs"+ , testCase "Leaves plain other intact" $+ canonizeLocalRef "../AnchorsSpec.hs" @?= "../AnchorsSpec.hs"+ ]
tests/Test/Xrefcheck/TooManyRequestsSpec.hs view
@@ -11,15 +11,15 @@ 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 (addUTCTime, defaultTimeLocale, formatTime, getCurrentTime, rfc822DateFormat) import Data.Time.Clock.POSIX (getPOSIXTime) import Fmt (indentF, pretty, unlinesF) import Network.HTTP.Types (Status (..), ok200, serviceUnavailable503, tooManyRequests429) import Network.HTTP.Types.Header (hRetryAfter)-import Test.Hspec (Spec, describe, it, shouldBe)-import Test.HUnit (assertBool)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=)) import Time (sec, (-:-))-import Web.Firefly (ToResponse (toResponse), route, run, getMethod)+import Web.Firefly (ToResponse (toResponse), getMethod, route, run) import Xrefcheck.Config import Xrefcheck.Core@@ -27,19 +27,18 @@ import Xrefcheck.Util import Xrefcheck.Verify -spec :: Spec-spec = do- describe "429 response tests" $ do- it "Returns 200 eventually" $ do+test_tooManyRequests :: TestTree+test_tooManyRequests = testGroup "429 response tests"+ [ testCase "Returns 200 eventually" $ do let prog = Progress{ pTotal = 1- , pCurrent = 1- , pErrorsUnfixable = 0- , pErrorsFixable = 0- , pTaskTimestamp = Nothing- }+ , 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+ , testCase "Returns 503 eventually" $ do let prog = Progress{ pTotal = 1 , pCurrent = 1 , pErrorsUnfixable = 1@@ -51,7 +50,7 @@ [ ExternalHttpResourceUnavailable $ Status { statusCode = 503, statusMessage = "Service Unavailable"} ]- it "Successfully updates the new retry-after value (as seconds)" $ do+ , testCase "Successfully updates the new retry-after value (as seconds)" $ do E.bracket (forkIO $ mock429 "2" ok200) killThread $ \_ -> do now <- getPOSIXTime <&> posixTimeToTimeSecond progressRef <- newIORef VerifyProgress@@ -72,7 +71,7 @@ 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+ , testCase "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)@@ -97,7 +96,8 @@ 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+ , testCase "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)@@ -122,7 +122,7 @@ 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+ , testCase "The GET request should not be attempted after catching a 429" $ do let mock429WithGlobalIORef :: IORef [(Text, Status)] -> IO () mock429WithGlobalIORef infoReverseAccumulatorRef = do@@ -133,9 +133,9 @@ callCount <- atomicModifyIORef' callCountRef $ \cc -> (cc + 1, cc) atomicModifyIORef' infoReverseAccumulatorRef $ \lst -> ( ( m- , if | m == "GET" -> ok200+ , if | m == "GET" -> ok200 | callCount == 0 -> tooManyRequests429- | otherwise -> serviceUnavailable503+ | otherwise -> serviceUnavailable503 ) : lst , () )@@ -151,11 +151,12 @@ E.bracket (forkIO $ mock429WithGlobalIORef infoReverseAccumulatorRef) killThread $ \_ -> do _ <- verifyLink "http://127.0.0.1:5000/429grandfinale" infoReverseAccumulator <- readIORef infoReverseAccumulatorRef- reverse infoReverseAccumulator `shouldBe`+ reverse infoReverseAccumulator @?= [ ("HEAD", tooManyRequests429) , ("HEAD", serviceUnavailable503) , ("GET", ok200) ]+ ] where checkLinkAndProgressWithServer mock link progress vrExpectation = E.bracket (forkIO mock) killThread $ \_ -> do@@ -197,7 +198,7 @@ verifyReferenceWithProgress reference progRef = do fmap wrlItem <$> verifyReference ((cVerification $ defConfig GitHub) { vcIgnoreRefs = [] }) FullMode- progRef (RepoInfo M.empty) "." "" reference+ progRef (RepoInfo M.empty mempty) "." "" reference -- | When called for the first time, returns with a 429 and `Retry-After: @retryAfter@`. -- Subsequent calls will respond with @status@.
tests/Test/Xrefcheck/TrailingSlashSpec.hs view
@@ -9,7 +9,8 @@ import Fmt (blockListF, pretty, unlinesF) import System.Directory (doesFileExist)-import Test.Hspec (Spec, describe, expectationFailure, it)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase) import Xrefcheck.Config import Xrefcheck.Core@@ -17,25 +18,24 @@ 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 ->+test_slash :: TestTree+test_slash = testGroup "Trailing forward slash detection" $+ let config = defConfig GitHub+ format = specificFormatsSupport [markdownSupport (scMarkdown (cScanners config))]+ in roots <&> \root ->+ testCase ("All the files within the root \"" <>+ root <>+ "\" should exist") $ do+ (ScanResult _ (RepoInfo repoInfo _)) <- allowRewrite False $ \rw -> scanRepo rw format TraversalConfig{ tcIgnored = [] } root nonExistentFiles <- lefts <$> forM (keys repoInfo) (\filePath -> do predicate <- doesFileExist filePath return $ if predicate- then Right ()- else Left filePath)+ then Right ()+ else Left filePath) if null nonExistentFiles then pass- else expectationFailure $ pretty $ unlinesF+ else assertFailure $ pretty $ unlinesF [ "Expected all filepaths to be valid, but these filepaths do not exist:" , blockListF nonExistentFiles ]
tests/Test/Xrefcheck/URIParsingSpec.hs view
@@ -9,45 +9,49 @@ import Universum -import Test.Hspec (Spec, describe, it, shouldReturn)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=)) 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|]+import URI.ByteString (SchemaError (..), URIParseError (..)) - parseUri' "https://example.com/path/to/smth?q=a&p=b" `shouldReturn`- Right [uri|https://example.com/path/to/smth?q=a&p=b|]+import Xrefcheck.Verify (VerifyError (..), parseUri) - 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|]+test_uri :: [TestTree]+test_uri =+ [ testGroup "URI parsing should be successful"+ [ testCase "Without the special characters in the query strings" do+ parseUri' "https://example.com/?q=a&p=b#fragment" >>=+ (@?= Right [uri|https://example.com/?q=a&p=b#fragment|])+ parseUri' "https://example.com/path/to/smth?q=a&p=b" >>=+ (@?= Right [uri|https://example.com/path/to/smth?q=a&p=b|]) - 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|]+ , testCase "With the special characters in the query strings" do+ parseUri' "https://example.com/?q=[a]&<p>={b}#fragment" >>=+ (@?= Right+ [uri|https://example.com/?q=%5Ba%5D&%3Cp%3E=%7Bb%7D#fragment|]) - 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/path/to/smth?q=[a]&<p>={b}" >>=+ (@?= Right+ [uri|https://example.com/path/to/smth?q=%5Ba%5D&%3Cp%3E=%7Bb%7D|])+ ]+ , testGroup "URI parsing should be unsuccessful"+ [ testCase "With the special characters anywhere else" do+ parseUri' "https://exa<mple.co>m/?q=a&p=b#fra{g}ment" >>=+ (@?= Left (ExternalResourceInvalidUri MalformedPath)) - parseUri' "https://example.com/pa[t]h/to[/]smth?q=a&p=b" `shouldReturn`- Left (ExternalResourceInvalidUri MalformedPath)+ parseUri' "https://example.com/pa[t]h/to[/]smth?q=a&p=b" >>=+ (@?= Left (ExternalResourceInvalidUri MalformedPath)) - it "With malformed scheme" do- parseUri' "https//example.com/" `shouldReturn`- Left (ExternalResourceInvalidUri $ MalformedScheme MissingColon)+ , testCase "With malformed scheme" do+ parseUri' "https//example.com/" >>=+ (@?= Left (ExternalResourceInvalidUri $ MalformedScheme MissingColon)) - it "With malformed fragment" do- parseUri' "https://example.com/?q=a&p=b#fra{g}ment" `shouldReturn`- Left (ExternalResourceInvalidUri MalformedFragment)+ , testCase "With malformed fragment" do+ parseUri' "https://example.com/?q=a&p=b#fra{g}ment" >>=+ (@?= Left (ExternalResourceInvalidUri MalformedFragment))+ ]+ ] where parseUri' :: Text -> IO $ Either VerifyError URI parseUri' = runExceptT . parseUri
tests/Test/Xrefcheck/Util.hs view
@@ -12,13 +12,10 @@ import Xrefcheck.Core (FileInfo, Flavor) import Xrefcheck.Scan (ScanError)-import Xrefcheck.Scanners.Markdown (MarkdownConfig' (MarkdownConfig, mcFlavor), markdownScanner)+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
+ tests/Tree.hs view
@@ -0,0 +1,5 @@+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io>+--+-- SPDX-License-Identifier: MPL-2.0++{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display -optF --generated-module -optF Tree #-}
xrefcheck.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: xrefcheck-version: 0.2.1+version: 0.2.2 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@@ -37,6 +37,7 @@ Xrefcheck.Scanners.Markdown Xrefcheck.System Xrefcheck.Util+ Xrefcheck.Util.Colorize Xrefcheck.Verify other-modules: Paths_xrefcheck@@ -84,11 +85,10 @@ , async , base >=4.14.3.0 && <5 , bytestring- , cmark-gfm+ , cmark-gfm >=0.2.5 , containers , data-default , directory- , directory-tree , dlist , exceptions , filepath@@ -102,10 +102,11 @@ , o-clock , optparse-applicative , pretty-terminal+ , process , raw-strings-qq+ , reflection , regex-tdfa , req- , roman-numerals , tagsoup , text , text-metrics@@ -166,7 +167,7 @@ , xrefcheck default-language: Haskell2010 -test-suite links-tests+test-suite ftp-tests type: exitcode-stdio-1.0 main-is: Main.hs other-modules:@@ -176,7 +177,7 @@ autogen-modules: Paths_xrefcheck hs-source-dirs:- links-tests+ ftp-tests default-extensions: AllowAmbiguousTypes BangPatterns@@ -226,7 +227,6 @@ type: exitcode-stdio-1.0 main-is: Main.hs other-modules:- Spec Test.Xrefcheck.AnchorsInHeadersSpec Test.Xrefcheck.AnchorsSpec Test.Xrefcheck.ConfigSpec@@ -237,6 +237,7 @@ Test.Xrefcheck.TrailingSlashSpec Test.Xrefcheck.URIParsingSpec Test.Xrefcheck.Util+ Tree Paths_xrefcheck autogen-modules: Paths_xrefcheck@@ -276,11 +277,9 @@ 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:- hspec-discover:hspec-discover+ tasty-discover:tasty-discover build-depends:- HUnit- , QuickCheck- , base >=4.14.3.0 && <5+ base >=4.14.3.0 && <5 , bytestring , case-insensitive , cmark-gfm@@ -288,12 +287,14 @@ , directory , firefly , fmt- , hspec- , hspec-expectations , http-types , modern-uri , o-clock+ , reflection , regex-tdfa+ , tasty+ , tasty-hunit+ , tasty-quickcheck , time , universum , uri-bytestring