diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -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 ========== diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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: diff --git a/ftp-tests/Main.hs b/ftp-tests/Main.hs new file mode 100644 --- /dev/null +++ b/ftp-tests/Main.hs @@ -0,0 +1,21 @@ +-- SPDX-FileCopyrightText: 2021 Serokell +-- +-- 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 diff --git a/ftp-tests/Test/Xrefcheck/FtpLinks.hs b/ftp-tests/Test/Xrefcheck/FtpLinks.hs new file mode 100644 --- /dev/null +++ b/ftp-tests/Test/Xrefcheck/FtpLinks.hs @@ -0,0 +1,85 @@ +-- SPDX-FileCopyrightText: 2021 Serokell +-- +-- 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) + ] diff --git a/ftp-tests/Tree.hs b/ftp-tests/Tree.hs new file mode 100644 --- /dev/null +++ b/ftp-tests/Tree.hs @@ -0,0 +1,5 @@ +-- SPDX-FileCopyrightText: 2021 Serokell +-- +-- SPDX-License-Identifier: MPL-2.0 + +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display -optF --generated-module -optF Tree #-} diff --git a/links-tests/Main.hs b/links-tests/Main.hs deleted file mode 100644 --- a/links-tests/Main.hs +++ /dev/null @@ -1,21 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Serokell --- --- 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 diff --git a/links-tests/Test/Xrefcheck/FtpLinks.hs b/links-tests/Test/Xrefcheck/FtpLinks.hs deleted file mode 100644 --- a/links-tests/Test/Xrefcheck/FtpLinks.hs +++ /dev/null @@ -1,84 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Serokell --- --- 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) - ] diff --git a/links-tests/Tree.hs b/links-tests/Tree.hs deleted file mode 100644 --- a/links-tests/Tree.hs +++ /dev/null @@ -1,5 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Serokell --- --- SPDX-License-Identifier: MPL-2.0 - -{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display -optF --generated-module -optF Tree #-} diff --git a/src/Xrefcheck/CLI.hs b/src/Xrefcheck/CLI.hs --- a/src/Xrefcheck/CLI.hs +++ b/src/Xrefcheck/CLI.hs @@ -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{..} diff --git a/src/Xrefcheck/Command.hs b/src/Xrefcheck/Command.hs --- a/src/Xrefcheck/Command.hs +++ b/src/Xrefcheck/Command.hs @@ -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 diff --git a/src/Xrefcheck/Config.hs b/src/Xrefcheck/Config.hs --- a/src/Xrefcheck/Config.hs +++ b/src/Xrefcheck/Config.hs @@ -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 diff --git a/src/Xrefcheck/Config/Default.hs b/src/Xrefcheck/Config/Default.hs --- a/src/Xrefcheck/Config/Default.hs +++ b/src/Xrefcheck/Config/Default.hs @@ -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: diff --git a/src/Xrefcheck/Core.hs b/src/Xrefcheck/Core.hs --- a/src/Xrefcheck/Core.hs +++ b/src/Xrefcheck/Core.hs @@ -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 diff --git a/src/Xrefcheck/Orphans.hs b/src/Xrefcheck/Orphans.hs --- a/src/Xrefcheck/Orphans.hs +++ b/src/Xrefcheck/Orphans.hs @@ -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 diff --git a/src/Xrefcheck/Progress.hs b/src/Xrefcheck/Progress.hs --- a/src/Xrefcheck/Progress.hs +++ b/src/Xrefcheck/Progress.hs @@ -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. diff --git a/src/Xrefcheck/Scan.hs b/src/Xrefcheck/Scan.hs --- a/src/Xrefcheck/Scan.hs +++ b/src/Xrefcheck/Scan.hs @@ -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) diff --git a/src/Xrefcheck/Scanners/Markdown.hs b/src/Xrefcheck/Scanners/Markdown.hs --- a/src/Xrefcheck/Scanners/Markdown.hs +++ b/src/Xrefcheck/Scanners/Markdown.hs @@ -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 diff --git a/src/Xrefcheck/System.hs b/src/Xrefcheck/System.hs --- a/src/Xrefcheck/System.hs +++ b/src/Xrefcheck/System.hs @@ -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[>]." + 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} diff --git a/src/Xrefcheck/Util.hs b/src/Xrefcheck/Util.hs --- a/src/Xrefcheck/Util.hs +++ b/src/Xrefcheck/Util.hs @@ -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 diff --git a/src/Xrefcheck/Util/Colorize.hs b/src/Xrefcheck/Util/Colorize.hs new file mode 100644 --- /dev/null +++ b/src/Xrefcheck/Util/Colorize.hs @@ -0,0 +1,46 @@ +{- SPDX-FileCopyrightText: 2018-2019 Serokell + - + - 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 diff --git a/src/Xrefcheck/Verify.hs b/src/Xrefcheck/Verify.hs --- a/src/Xrefcheck/Verify.hs +++ b/src/Xrefcheck/Verify.hs @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,12 +1,15 @@ -{- SPDX-FileCopyrightText: 2019 Serokell - - - - SPDX-License-Identifier: MPL-2.0 - -} +-- SPDX-FileCopyrightText: 2022 Serokell +-- +-- 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 diff --git a/tests/Spec.hs b/tests/Spec.hs deleted file mode 100644 --- a/tests/Spec.hs +++ /dev/null @@ -1,6 +0,0 @@ -{- SPDX-FileCopyrightText: 2019 Serokell - - - - SPDX-License-Identifier: MPL-2.0 - -} - -{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/tests/Test/Xrefcheck/AnchorsInHeadersSpec.hs b/tests/Test/Xrefcheck/AnchorsInHeadersSpec.hs --- a/tests/Test/Xrefcheck/AnchorsInHeadersSpec.hs +++ b/tests/Test/Xrefcheck/AnchorsInHeadersSpec.hs @@ -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 diff --git a/tests/Test/Xrefcheck/AnchorsSpec.hs b/tests/Test/Xrefcheck/AnchorsSpec.hs --- a/tests/Test/Xrefcheck/AnchorsSpec.hs +++ b/tests/Test/Xrefcheck/AnchorsSpec.hs @@ -3,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" ) ] + ] diff --git a/tests/Test/Xrefcheck/ConfigSpec.hs b/tests/Test/Xrefcheck/ConfigSpec.hs --- a/tests/Test/Xrefcheck/ConfigSpec.hs +++ b/tests/Test/Xrefcheck/ConfigSpec.hs @@ -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 diff --git a/tests/Test/Xrefcheck/IgnoreAnnotationsSpec.hs b/tests/Test/Xrefcheck/IgnoreAnnotationsSpec.hs --- a/tests/Test/Xrefcheck/IgnoreAnnotationsSpec.hs +++ b/tests/Test/Xrefcheck/IgnoreAnnotationsSpec.hs @@ -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 diff --git a/tests/Test/Xrefcheck/IgnoreRegexSpec.hs b/tests/Test/Xrefcheck/IgnoreRegexSpec.hs --- a/tests/Test/Xrefcheck/IgnoreRegexSpec.hs +++ b/tests/Test/Xrefcheck/IgnoreRegexSpec.hs @@ -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] diff --git a/tests/Test/Xrefcheck/LocalSpec.hs b/tests/Test/Xrefcheck/LocalSpec.hs --- a/tests/Test/Xrefcheck/LocalSpec.hs +++ b/tests/Test/Xrefcheck/LocalSpec.hs @@ -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" + ] diff --git a/tests/Test/Xrefcheck/TooManyRequestsSpec.hs b/tests/Test/Xrefcheck/TooManyRequestsSpec.hs --- a/tests/Test/Xrefcheck/TooManyRequestsSpec.hs +++ b/tests/Test/Xrefcheck/TooManyRequestsSpec.hs @@ -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@. diff --git a/tests/Test/Xrefcheck/TrailingSlashSpec.hs b/tests/Test/Xrefcheck/TrailingSlashSpec.hs --- a/tests/Test/Xrefcheck/TrailingSlashSpec.hs +++ b/tests/Test/Xrefcheck/TrailingSlashSpec.hs @@ -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 ] diff --git a/tests/Test/Xrefcheck/URIParsingSpec.hs b/tests/Test/Xrefcheck/URIParsingSpec.hs --- a/tests/Test/Xrefcheck/URIParsingSpec.hs +++ b/tests/Test/Xrefcheck/URIParsingSpec.hs @@ -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]&

={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]&

={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]&

={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://exam/?q=a&p=b#fra{g}ment" `shouldReturn` - Left (ExternalResourceInvalidUri MalformedPath) + parseUri' "https://example.com/path/to/smth?q=[a]&

={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://exam/?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 diff --git a/tests/Test/Xrefcheck/Util.hs b/tests/Test/Xrefcheck/Util.hs --- a/tests/Test/Xrefcheck/Util.hs +++ b/tests/Test/Xrefcheck/Util.hs @@ -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 diff --git a/tests/Tree.hs b/tests/Tree.hs new file mode 100644 --- /dev/null +++ b/tests/Tree.hs @@ -0,0 +1,5 @@ +-- SPDX-FileCopyrightText: 2022 Serokell +-- +-- SPDX-License-Identifier: MPL-2.0 + +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display -optF --generated-module -optF Tree #-} diff --git a/xrefcheck.cabal b/xrefcheck.cabal --- a/xrefcheck.cabal +++ b/xrefcheck.cabal @@ -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 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