serokell/xrefcheck
1
1
Fork 0
mirror of https://github.com/serokell/xrefcheck.git synced 2024-08-17 01:20:44 +03:00
Code Issues Projects Releases Wiki Activity

[#197] Canonicalize filepaths

Browse Source 
Problem: the current usage of filepaths is error-prone and can be
simplified.

Solution: canonicalize filepaths at the boundaries, so their management
will be safer and will simplify the codebase.
This commit is contained in:
Adrián Enríquez 2022-12-20 16:54:58 +01:00
parent a13910d433
commit 0886062500
No known key found for this signature in database
GPG Key ID: 1D2A049F5866F977
30 changed files with 594 additions and 456 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
ftp-tests/Test/Xrefcheck/FtpLinks.hs
View File

@ -41,7 +41,6 @@ instance IsOption FtpHostOpt where
<> help (untag (optionHelp :: Tagged FtpHostOpt String)) <> help (untag (optionHelp :: Tagged FtpHostOpt String))
) )
config :: Config config :: Config
config = defConfig GitHub & cExclusionsL . ecIgnoreExternalRefsToL .~ [] config = defConfig GitHub & cExclusionsL . ecIgnoreExternalRefsToL .~ []

1
package.yaml
View File

@ -87,7 +87,6 @@ library:
- bytestring - bytestring
- containers - containers
- cmark-gfm >= 0.2.5 - cmark-gfm >= 0.2.5
- data-default
- directory - directory
- dlist - dlist
- filepath - filepath

4
src/Xrefcheck/CLI.hs
View File

@ -39,7 +39,7 @@ import Xrefcheck.Config (NetworkingConfig, NetworkingConfig' (..))
import Xrefcheck.Core import Xrefcheck.Core
import Xrefcheck.Scan import Xrefcheck.Scan
import Xrefcheck.System (RelGlobPattern, mkGlobPattern) import Xrefcheck.System (RelGlobPattern, mkGlobPattern)
import Xrefcheck.Util (ColorMode (WithColors, WithoutColors), normaliseWithNoTrailing) import Xrefcheck.Util (ColorMode (WithColors, WithoutColors))
modeReadM :: ReadM VerifyMode modeReadM :: ReadM VerifyMode
modeReadM = eitherReader $ \s -> modeReadM = eitherReader $ \s ->
@ -118,7 +118,7 @@ defaultConfigPaths = ["./xrefcheck.yaml", "./.xrefcheck.yaml"]
type RepoType = Flavor type RepoType = Flavor
filepathOption :: Mod OptionFields FilePath -> Parser FilePath filepathOption :: Mod OptionFields FilePath -> Parser FilePath
filepathOption = fmap normaliseWithNoTrailing <$> strOption filepathOption = strOption
globOption :: Mod OptionFields RelGlobPattern -> Parser RelGlobPattern globOption :: Mod OptionFields RelGlobPattern -> Parser RelGlobPattern
globOption = option $ eitherReader $ mkGlobPattern globOption = option $ eitherReader $ mkGlobPattern

10
src/Xrefcheck/Command.hs
View File

@ -18,8 +18,7 @@ import Text.Interpolation.Nyan
import Xrefcheck.CLI (Options (..), addExclusionOptions, addNetworkingOptions, defaultConfigPaths) import Xrefcheck.CLI (Options (..), addExclusionOptions, addNetworkingOptions, defaultConfigPaths)
import Xrefcheck.Config import Xrefcheck.Config
(Config, Config' (..), ScannersConfig, ScannersConfig' (..), defConfig, normaliseConfigFilePaths, (Config, Config' (..), ScannersConfig, ScannersConfig' (..), defConfig, overrideConfig)
overrideConfig)
import Xrefcheck.Core (Flavor (..)) import Xrefcheck.Core (Flavor (..))
import Xrefcheck.Progress (allowRewrite) import Xrefcheck.Progress (allowRewrite)
import Xrefcheck.Scan import Xrefcheck.Scan
@ -31,7 +30,7 @@ import Xrefcheck.Util
import Xrefcheck.Verify (reportVerifyErrs, verifyErrors, verifyRepo) import Xrefcheck.Verify (reportVerifyErrs, verifyErrors, verifyRepo)
readConfig :: FilePath -> IO Config readConfig :: FilePath -> IO Config
readConfig path = fmap (normaliseConfigFilePaths . overrideConfig) do readConfig path = fmap overrideConfig do
decodeFileEither path decodeFileEither path
>>= either (error . toText . prettyPrintParseException) pure >>= either (error . toText . prettyPrintParseException) pure
@ -70,7 +69,8 @@ defaultAction Options{..} = do
(ScanResult scanErrs repoInfo) <- allowRewrite showProgressBar $ \rw -> do (ScanResult scanErrs repoInfo) <- allowRewrite showProgressBar $ \rw -> do
let fullConfig = addExclusionOptions (cExclusions config) oExclusionOptions let fullConfig = addExclusionOptions (cExclusions config) oExclusionOptions
scanRepo oScanPolicy rw (formats $ cScanners config) fullConfig oRoot formatsSupport = formats $ cScanners config
scanRepo oScanPolicy rw formatsSupport fullConfig oRoot
when oVerbose $ when oVerbose $
fmt [int|| fmt [int||
@ -84,7 +84,7 @@ defaultAction Options{..} = do
verifyRes <- allowRewrite showProgressBar $ \rw -> do verifyRes <- allowRewrite showProgressBar $ \rw -> do
let fullConfig = config let fullConfig = config
{ cNetworking = addNetworkingOptions (cNetworking config) oNetworkingOptions } { cNetworking = addNetworkingOptions (cNetworking config) oNetworkingOptions }
verifyRepo rw fullConfig oMode oRoot repoInfo verifyRepo rw fullConfig oMode repoInfo
case verifyErrors verifyRes of case verifyErrors verifyRes of
Nothing | null scanErrs -> fmtLn "All repository links are valid." Nothing | null scanErrs -> fmtLn "All repository links are valid."

15
src/Xrefcheck/Config.hs
View File

@ -10,7 +10,6 @@ module Xrefcheck.Config
, defConfigText , defConfigText
) where ) where
import Universum import Universum
import Control.Lens (makeLensesWith) import Control.Lens (makeLensesWith)
@ -38,13 +37,6 @@ data Config' f = Config
, cScanners :: ScannersConfig' f , cScanners :: ScannersConfig' f
} deriving stock (Generic) } deriving stock (Generic)
normaliseConfigFilePaths :: Config -> Config
normaliseConfigFilePaths Config{..}
= Config
{ cExclusions = normaliseExclusionConfigFilePaths cExclusions
, ..
}
-- | Type alias for NetworkingConfig' with all required fields. -- | Type alias for NetworkingConfig' with all required fields.
type NetworkingConfig = NetworkingConfig' Identity type NetworkingConfig = NetworkingConfig' Identity
@ -79,9 +71,10 @@ makeLensesWith postfixFields ''Config'
makeLensesWith postfixFields ''NetworkingConfig' makeLensesWith postfixFields ''NetworkingConfig'
defConfig :: HasCallStack => Flavor -> Config defConfig :: HasCallStack => Flavor -> Config
defConfig flavor = normaliseConfigFilePaths $ defConfig = either (error . toText . prettyPrintParseException) id
either (error . toText . prettyPrintParseException) id $ . decodeEither'
decodeEither' $ encodeUtf8 $ defConfigText flavor . encodeUtf8
. defConfigText
-- | Override missed fields with default values. -- | Override missed fields with default values.
overrideConfig :: ConfigOptional -> Config overrideConfig :: ConfigOptional -> Config

162
src/Xrefcheck/Core.hs
View File

@ -15,10 +15,10 @@ import Control.Lens (makeLenses)
import Data.Aeson (FromJSON (..), withText) import Data.Aeson (FromJSON (..), withText)
import Data.Char (isAlphaNum) import Data.Char (isAlphaNum)
import Data.Char qualified as C import Data.Char qualified as C
import Data.Default (Default (..))
import Data.DList (DList) import Data.DList (DList)
import Data.DList qualified as DList import Data.DList qualified as DList
import Data.List qualified as L import Data.List qualified as L
import Data.Map qualified as M
import Data.Reflection (Given) import Data.Reflection (Given)
import Data.Text qualified as T import Data.Text qualified as T
import Fmt (Buildable (..), Builder) import Fmt (Buildable (..), Builder)
@ -27,6 +27,7 @@ import Text.Interpolation.Nyan
import Time (Second, Time) import Time (Second, Time)
import Xrefcheck.Progress import Xrefcheck.Progress
import Xrefcheck.System
import Xrefcheck.Util import Xrefcheck.Util
----------------------------------------------------------- -----------------------------------------------------------
@ -77,8 +78,60 @@ data Reference = Reference
, rAnchor :: Maybe Text , rAnchor :: Maybe Text
-- ^ Section or custom anchor tag. -- ^ Section or custom anchor tag.
, rPos :: Position , rPos :: Position
-- ^ Position in source file.
, rInfo :: ReferenceInfo
-- ^ More info about the link.
} deriving stock (Show, Generic) } deriving stock (Show, Generic)
-- | Info about the reference.
data ReferenceInfo
= RIExternal
-- ^ Reference to a file at outer site, e.g @[d](http://www.google.com/doodles)@
| RIOtherProtocol
-- ^ Entry not to be processed, e.g. @mailto:e-mail@
| RIFileLocal
-- ^ Reference to this file, e.g. @[a](#header)@
| RIFileAbsolute
-- ^ Reference to a file absolute to the root, e.g. @[c](/folder/file#header)@
| RIFileRelative
-- ^ Reference to a file relative to given one, e.g. @[b](folder/file#header)@
deriving stock (Show, Generic)
pattern PathSep :: Char
pattern PathSep <- (isPathSeparator -> True)
-- | Compute the 'ReferenceInfo' corresponding to a given link.
referenceInfo :: Text -> ReferenceInfo
referenceInfo link = case toString link of
[] -> RIFileLocal
PathSep : _ -> RIFileAbsolute
'.' : PathSep : _ -> RIFileRelative
'.' : '.' : PathSep : _ -> RIFileRelative
_ | hasUrlProtocol -> RIExternal
| hasProtocol -> RIOtherProtocol
| otherwise -> RIFileRelative
where
hasUrlProtocol = "://" `T.isInfixOf` T.take 10 link
hasProtocol = ":" `T.isInfixOf` T.take 10 link
-- | Whether this is a link to external resource.
isExternal :: ReferenceInfo -> Bool
isExternal = \case
RIFileLocal -> False
RIFileRelative -> False
RIFileAbsolute -> False
RIExternal -> True
RIOtherProtocol -> False
-- | Whether this is a link to repo-local resource.
isLocal :: ReferenceInfo -> Bool
isLocal = \case
RIFileLocal -> True
RIFileRelative -> True
RIFileAbsolute -> True
RIExternal -> False
RIOtherProtocol -> False
-- | Context of anchor. -- | Context of anchor.
data AnchorType data AnchorType
= HeaderAnchor Int = HeaderAnchor Int
@ -119,9 +172,6 @@ data FileInfo = FileInfo
} deriving stock (Show, Generic) } deriving stock (Show, Generic)
makeLenses ''FileInfo makeLenses ''FileInfo
instance Default FileInfo where
def = diffToFileInfo mempty
data ScanPolicy data ScanPolicy
= OnlyTracked = OnlyTracked
-- ^ Scan and treat as existing only files tracked by Git. -- ^ Scan and treat as existing only files tracked by Git.
@ -148,11 +198,23 @@ data DirectoryStatus
-- | All tracked files and directories. -- | All tracked files and directories.
data RepoInfo = RepoInfo data RepoInfo = RepoInfo
{ riFiles :: Map FilePath FileStatus { riFiles :: Map CanonicalPath FileStatus
-- ^ Files from the repo with `FileInfo` attached to files that we've scanned. -- ^ Files from the repo with `FileInfo` attached to files that we've scanned.
, riDirectories :: Map FilePath DirectoryStatus , riDirectories :: Map CanonicalPath DirectoryStatus
-- ^ Directories containing those files. -- ^ Directories containing those files.
} deriving stock (Show) , riRoot :: CanonicalPath
-- ^ Repository root.
}
-- Search for a file in the repository.
lookupFile :: CanonicalPath -> RepoInfo -> Maybe FileStatus
lookupFile path RepoInfo{..} =
M.lookup path riFiles
-- Search for a directory in the repository.
lookupDirectory :: CanonicalPath -> RepoInfo -> Maybe DirectoryStatus
lookupDirectory path RepoInfo{..} =
M.lookup path riDirectories
----------------------------------------------------------- -----------------------------------------------------------
-- Instances -- Instances
@ -160,6 +222,7 @@ data RepoInfo = RepoInfo
instance NFData Position instance NFData Position
instance NFData Reference instance NFData Reference
instance NFData ReferenceInfo
instance NFData AnchorType instance NFData AnchorType
instance NFData Anchor instance NFData Anchor
instance NFData FileInfo instance NFData FileInfo
@ -167,12 +230,20 @@ instance NFData FileInfo
instance Given ColorMode => Buildable Reference where instance Given ColorMode => Buildable Reference where
build Reference{..} = build Reference{..} =
[int|| [int||
reference #{paren . build $ locationType rLink} #{rPos}: reference #{paren . build $ rInfo} #{rPos}:
- text: #s{rName} - text: #s{rName}
- link: #{if null rLink then "-" else rLink} - link: #{if null rLink then "-" else rLink}
- anchor: #{rAnchor ?: styleIfNeeded Faint "-"} - anchor: #{rAnchor ?: styleIfNeeded Faint "-"}
|] |]
instance Given ColorMode => Buildable ReferenceInfo where
build = \case
RIFileLocal -> colorIfNeeded Green "file-local"
RIFileRelative -> colorIfNeeded Yellow "relative"
RIFileAbsolute -> colorIfNeeded Blue "absolute"
RIExternal -> colorIfNeeded Red "external"
RIOtherProtocol -> ""
instance Given ColorMode => Buildable AnchorType where instance Given ColorMode => Buildable AnchorType where
build = styleIfNeeded Faint . \case build = styleIfNeeded Faint . \case
HeaderAnchor l -> colorIfNeeded Green ("header " <> headerLevelToRoman l) HeaderAnchor l -> colorIfNeeded Green ("header " <> headerLevelToRoman l)
@ -204,14 +275,14 @@ instance Given ColorMode => Buildable FileInfo where
|] |]
instance Given ColorMode => Buildable RepoInfo where instance Given ColorMode => Buildable RepoInfo where
build (RepoInfo m _) build RepoInfo{..}
| Just scanned <- nonEmpty [(name, info) | (name, Scanned info) <- toPairs m] | Just scanned <- nonEmpty [(name, info) | (name, Scanned info) <- toPairs riFiles]
= interpolateUnlinesF $ buildFileReport <$> scanned = interpolateUnlinesF $ buildFileReport <$> scanned
where where
buildFileReport :: ([Char], FileInfo) -> Builder buildFileReport :: (CanonicalPath, FileInfo) -> Builder
buildFileReport (name, info) = buildFileReport (name, info) =
[int|| [int||
#{ colorIfNeeded Cyan $ name }: #{ colorIfNeeded Cyan $ getPosixRelativeOrAbsoluteChild riRoot name }:
#{ interpolateIndentF 2 $ build info } #{ interpolateIndentF 2 $ build info }
|] |]
build _ = "No scannable files found." build _ = "No scannable files found."
@ -220,60 +291,6 @@ instance Given ColorMode => Buildable RepoInfo where
-- Analysing -- Analysing
----------------------------------------------------------- -----------------------------------------------------------
pattern PathSep :: Char
pattern PathSep <- (isPathSeparator -> True)
-- | Type of reference.
data LocationType
= FileLocalLoc
-- ^ Reference to this file, e.g. @[a](#header)@
| RelativeLoc
-- ^ Reference to a file relative to given one, e.g. @[b](folder/file#header)@
| AbsoluteLoc
-- ^ Reference to a file relative to the root, e.g. @[c](/folder/file#header)@
| ExternalLoc
-- ^ Reference to a file at outer site, e.g @[d](http://www.google.com/doodles)@
| OtherLoc
-- ^ Entry not to be processed, e.g. @mailto:e-mail@
deriving stock (Eq, Show)
instance Given ColorMode => Buildable LocationType where
build = \case
FileLocalLoc -> colorIfNeeded Green "file-local"
RelativeLoc -> colorIfNeeded Yellow "relative"
AbsoluteLoc -> colorIfNeeded Blue "absolute"
ExternalLoc -> colorIfNeeded Red "external"
OtherLoc -> ""
-- | Whether this is a link to external resource.
isExternal :: LocationType -> Bool
isExternal = \case
ExternalLoc -> True
_ -> False
-- | Whether this is a link to repo-local resource.
isLocal :: LocationType -> Bool
isLocal = \case
FileLocalLoc -> True
RelativeLoc -> True
AbsoluteLoc -> True
ExternalLoc -> False
OtherLoc -> False
-- | Get type of reference.
locationType :: Text -> LocationType
locationType location = case toString location of
[] -> FileLocalLoc
PathSep : _ -> AbsoluteLoc
'.' : PathSep : _ -> RelativeLoc
'.' : '.' : PathSep : _ -> RelativeLoc
_ | hasUrlProtocol -> ExternalLoc
| hasProtocol -> OtherLoc
| otherwise -> RelativeLoc
where
hasUrlProtocol = "://" `T.isInfixOf` T.take 10 location
hasProtocol = ":" `T.isInfixOf` T.take 10 location
-- | Which parts of verification do we perform. -- | Which parts of verification do we perform.
data VerifyMode data VerifyMode
= LocalOnlyMode = LocalOnlyMode
@ -335,13 +352,6 @@ stripAnchorDupNo t = do
guard (length strippedNo < length t) guard (length strippedNo < length t)
T.stripSuffix "-" strippedNo T.stripSuffix "-" strippedNo
-- | Strip './' prefix from local references.
canonizeLocalRef :: Text -> Text
canonizeLocalRef ref =
maybe ref canonizeLocalRef (T.stripPrefix localPrefix ref)
where
localPrefix = "./"
----------------------------------------------------------- -----------------------------------------------------------
-- Visualisation -- Visualisation
----------------------------------------------------------- -----------------------------------------------------------
@ -357,7 +367,7 @@ initVerifyProgress references = VerifyProgress
, vrExternal = initProgress (length (ordNub $ map rLink extRefs)) , vrExternal = initProgress (length (ordNub $ map rLink extRefs))
} }
where where
(extRefs, localRefs) = L.partition (isExternal . locationType . rLink) references (extRefs, localRefs) = L.partition (isExternal . rInfo) references
showAnalyseProgress :: Given ColorMode => VerifyMode -> Time Second -> VerifyProgress -> Text showAnalyseProgress :: Given ColorMode => VerifyMode -> Time Second -> VerifyProgress -> Text
showAnalyseProgress mode posixTime VerifyProgress{..} = showAnalyseProgress mode posixTime VerifyProgress{..} =

151
src/Xrefcheck/Scan.hs
View File

@ -13,13 +13,14 @@ module Xrefcheck.Scan
, Extension , Extension
, ScanAction , ScanAction
, FormatsSupport , FormatsSupport
, RepoInfo (..)
, ReadDirectoryMode(..) , ReadDirectoryMode(..)
, ScanError (..) , ScanError (..)
, ScanErrorDescription (..) , ScanErrorDescription (..)
, ScanResult (..) , ScanResult (..)
, ScanStage (..)
, normaliseExclusionConfigFilePaths , mkParseScanError
, mkGatherScanError
, scanRepo , scanRepo
, specificFormatsSupport , specificFormatsSupport
, ecIgnoreL , ecIgnoreL
@ -38,8 +39,6 @@ import Data.Map qualified as M
import Data.Reflection (Given) import Data.Reflection (Given)
import Fmt (Buildable (..), fmt) import Fmt (Buildable (..), fmt)
import System.Directory (doesDirectoryExist) import System.Directory (doesDirectoryExist)
import System.FilePath.Posix
(dropTrailingPathSeparator, equalFilePath, splitDirectories, takeDirectory, takeExtension, (</>))
import System.Process (cwd, readCreateProcess, shell) import System.Process (cwd, readCreateProcess, shell)
import Text.Interpolation.Nyan import Text.Interpolation.Nyan
import Text.Regex.TDFA.Common (CompOption (..), ExecOption (..), Regex) import Text.Regex.TDFA.Common (CompOption (..), ExecOption (..), Regex)
@ -47,7 +46,7 @@ import Text.Regex.TDFA.Text qualified as R
import Xrefcheck.Core import Xrefcheck.Core
import Xrefcheck.Progress import Xrefcheck.Progress
import Xrefcheck.System (RelGlobPattern, matchesGlobPatterns, normaliseGlobPattern, readingSystem) import Xrefcheck.System
import Xrefcheck.Util import Xrefcheck.Util
-- | Type alias for ExclusionConfig' with all required fields. -- | Type alias for ExclusionConfig' with all required fields.
@ -67,35 +66,58 @@ data ExclusionConfig' f = ExclusionConfig
makeLensesWith postfixFields ''ExclusionConfig' makeLensesWith postfixFields ''ExclusionConfig'
normaliseExclusionConfigFilePaths :: ExclusionConfig -> ExclusionConfig
normaliseExclusionConfigFilePaths ec@ExclusionConfig{..}
= ec
{ ecIgnore = map normaliseGlobPattern ecIgnore
, ecIgnoreLocalRefsTo = map normaliseGlobPattern ecIgnoreLocalRefsTo
, ecIgnoreRefsFrom = map normaliseGlobPattern ecIgnoreRefsFrom
}
-- | File extension, dot included. -- | File extension, dot included.
type Extension = String type Extension = String
-- | Way to parse a file. -- | Way to parse a file.
type ScanAction = FilePath -> IO (FileInfo, [ScanError]) type ScanAction = CanonicalPath -> IO (FileInfo, [ScanError 'Parse])
-- | All supported ways to parse a file. -- | All supported ways to parse a file.
type FormatsSupport = Extension -> Maybe ScanAction type FormatsSupport = Extension -> Maybe ScanAction
data ScanResult = ScanResult data ScanResult = ScanResult
{ srScanErrors :: [ScanError] { srScanErrors :: [ScanError 'Gather]
, srRepoInfo :: RepoInfo , srRepoInfo :: RepoInfo
} deriving stock (Show) }
data ScanError = ScanError -- | A scan error indexed by different process stages.
{ sePosition :: Position --
, seFile :: FilePath -- Within 'Parse', 'seFile' has no information because the same
-- file is being parsed.
--
-- Within 'Gather', 'seFile' stores the 'FilePath' corresponding
-- to the file in where the error was found.
data ScanError (a :: ScanStage) = ScanError
{ seFile :: ScanStageFile a
, sePosition :: Position
, seDescription :: ScanErrorDescription , seDescription :: ScanErrorDescription
} deriving stock (Show, Eq) }
instance Given ColorMode => Buildable ScanError where data ScanStage = Parse | Gather
type family ScanStageFile (a :: ScanStage) where
ScanStageFile 'Parse = ()
ScanStageFile 'Gather = FilePath
deriving stock instance Show (ScanError 'Parse)
deriving stock instance Show (ScanError 'Gather)
deriving stock instance Eq (ScanError 'Parse)
deriving stock instance Eq (ScanError 'Gather)
-- | Make a 'ScanError' for the 'Parse' stage.
mkParseScanError :: Position -> ScanErrorDescription -> ScanError 'Parse
mkParseScanError = ScanError ()
-- | Promote a 'ScanError' from the 'Parse' stage
-- to the 'Gather' stage.
mkGatherScanError :: FilePath -> ScanError 'Parse -> ScanError 'Gather
mkGatherScanError seFile ScanError{sePosition, seDescription} = ScanError
{ seFile
, sePosition
, seDescription
}
instance Given ColorMode => Buildable (ScanError 'Gather) where
build ScanError{..} = [int|| build ScanError{..} = [int||
In file #{styleIfNeeded Faint (styleIfNeeded Bold seFile)} In file #{styleIfNeeded Faint (styleIfNeeded Bold seFile)}
scan error #{sePosition}: scan error #{sePosition}:
@ -104,7 +126,7 @@ instance Given ColorMode => Buildable ScanError where
|] |]
reportScanErrs :: Given ColorMode => NonEmpty ScanError -> IO () reportScanErrs :: Given ColorMode => NonEmpty (ScanError 'Gather) -> IO ()
reportScanErrs errs = fmt reportScanErrs errs = fmt
[int|| [int||
=== Scan errors found === === Scan errors found ===
@ -153,14 +175,13 @@ data ReadDirectoryMode
readDirectoryWith readDirectoryWith
:: forall a. ReadDirectoryMode :: forall a. ReadDirectoryMode
-> ExclusionConfig -> ExclusionConfig
-> (FilePath -> IO a) -> (CanonicalPath -> IO a)
-> FilePath -> CanonicalPath
-> IO [(FilePath, a)] -> IO [(CanonicalPath, a)]
readDirectoryWith mode config scanner root = readDirectoryWith mode config scanner root = do
traverse scanFile relativeFiles <- L.lines <$> getFiles
. filter (not . isIgnored) canonicalFiles <- mapM (root </) relativeFiles
. fmap (location </>) traverse scanFile $ filter (not . isIgnored) canonicalFiles
. L.lines =<< getFiles
where where
@ -170,43 +191,37 @@ readDirectoryWith mode config scanner root =
RdmBothTrackedAndUtracked -> liftA2 (<>) getTrackedFiles getUntrackedFiles RdmBothTrackedAndUtracked -> liftA2 (<>) getTrackedFiles getUntrackedFiles
getTrackedFiles = readCreateProcess getTrackedFiles = readCreateProcess
(shell "git ls-files"){cwd = Just root} "" (shell "git ls-files"){cwd = Just $ unCanonicalPath root} ""
getUntrackedFiles = readCreateProcess getUntrackedFiles = readCreateProcess
(shell "git ls-files --others --exclude-standard"){cwd = Just root} "" (shell "git ls-files --others --exclude-standard"){cwd = Just $ unCanonicalPath root} ""
scanFile :: FilePath -> IO (FilePath, a) scanFile :: CanonicalPath -> IO (CanonicalPath, a)
scanFile = sequence . (normaliseWithNoTrailing &&& scanner) scanFile c = (c,) <$> scanner c
isIgnored :: FilePath -> Bool isIgnored :: CanonicalPath -> Bool
isIgnored = matchesGlobPatterns root $ ecIgnore config isIgnored = matchesGlobPatterns root $ ecIgnore config
-- Strip leading "." and trailing "/"
location :: FilePath
location =
if root `equalFilePath` "."
then ""
else dropTrailingPathSeparator root
scanRepo scanRepo
:: MonadIO m :: MonadIO m
=> ScanPolicy -> Rewrite -> FormatsSupport -> ExclusionConfig -> FilePath -> m ScanResult => ScanPolicy -> Rewrite -> FormatsSupport -> ExclusionConfig -> FilePath -> m ScanResult
scanRepo scanMode rw formatsSupport config root = do scanRepo scanMode rw formatsSupport config root = do
putTextRewrite rw "Scanning repository..." putTextRewrite rw "Scanning repository..."
when (not $ isDirectory root) $ liftIO $ whenM (not <$> doesDirectoryExist root) $
die $ "Repository's root does not seem to be a directory: " <> root die $ "Repository's root does not seem to be a directory: " <> root
canonicalRoot <- liftIO $ canonicalizePath root
(errs, processedFiles) <- (errs, processedFiles) <-
let mode = case scanMode of let mode = case scanMode of
OnlyTracked -> RdmTracked OnlyTracked -> RdmTracked
IncludeUntracked -> RdmBothTrackedAndUtracked IncludeUntracked -> RdmBothTrackedAndUtracked
in liftIO in liftIO $ (gatherScanErrs canonicalRoot &&& gatherFileStatuses)
$ (gatherScanErrs &&& gatherFileStatuses) <$> readDirectoryWith mode config processFile canonicalRoot
<$> readDirectoryWith mode config processFile root
notProcessedFiles <- case scanMode of notProcessedFiles <- case scanMode of
OnlyTracked -> liftIO $ OnlyTracked -> liftIO $
readDirectoryWith RdmUntracked config (const $ pure NotAddedToGit) root readDirectoryWith RdmUntracked config (const $ pure NotAddedToGit) canonicalRoot
IncludeUntracked -> pure [] IncludeUntracked -> pure []
let scannableNotProcessedFiles = filter (isJust . mscanner . fst) notProcessedFiles let scannableNotProcessedFiles = filter (isJust . mscanner . fst) notProcessedFiles
@ -214,44 +229,42 @@ scanRepo scanMode rw formatsSupport config root = do
whenJust (nonEmpty $ map fst scannableNotProcessedFiles) $ \files -> hPutStrLn @Text stderr whenJust (nonEmpty $ map fst scannableNotProcessedFiles) $ \files -> hPutStrLn @Text stderr
[int|A| [int|A|
Those files are not added by Git, so we're not scanning them: Those files are not added by Git, so we're not scanning them:
#{interpolateBlockListF files} #{interpolateBlockListF $ getPosixRelativeOrAbsoluteChild canonicalRoot <$> files}
Please run "git add" before running xrefcheck or enable \ Please run "git add" before running xrefcheck or enable \
--include-untracked CLI option to check these files. --include-untracked CLI option to check these files.
|] |]
let trackedDirs = foldMap (getDirs . fst) processedFiles let trackedDirs = foldMap (getDirsBetweenRootAndFile canonicalRoot . fst) processedFiles
untrackedDirs = foldMap (getDirs . fst) notProcessedFiles untrackedDirs = foldMap (getDirsBetweenRootAndFile canonicalRoot . fst) notProcessedFiles
return . ScanResult errs $ RepoInfo return . ScanResult errs $ RepoInfo
{ riFiles = M.fromList $ processedFiles <> notProcessedFiles { riFiles = M.fromList $ processedFiles <> notProcessedFiles
, riDirectories = M.fromList , riDirectories = M.fromList $ (fmap (, TrackedDirectory) trackedDirs
$ map (, TrackedDirectory) trackedDirs <> fmap (, UntrackedDirectory) untrackedDirs)
<> map (, UntrackedDirectory) untrackedDirs , riRoot = canonicalRoot
} }
where where
mscanner :: FilePath -> Maybe ScanAction mscanner :: CanonicalPath -> Maybe ScanAction
mscanner = formatsSupport . takeExtension mscanner = formatsSupport . takeExtension
isDirectory :: FilePath -> Bool
isDirectory = readingSystem . doesDirectoryExist
-- Get all directories from filepath.
getDirs :: FilePath -> [FilePath]
getDirs = scanl (</>) "" . splitDirectories . takeDirectory
gatherScanErrs gatherScanErrs
:: [(FilePath, (FileStatus, [ScanError]))] :: CanonicalPath
-> [ScanError] -> [(CanonicalPath, (FileStatus, [ScanError 'Parse]))]
gatherScanErrs = foldMap (snd . snd) -> [ScanError 'Gather]
gatherScanErrs canonicalRoot = foldMap $ \(file, (_, errs)) ->
mkGatherScanError (showFilepath file) <$> errs
where
showFilepath = getPosixRelativeOrAbsoluteChild canonicalRoot
gatherFileStatuses gatherFileStatuses
:: [(FilePath, (FileStatus, [ScanError]))] :: [(CanonicalPath, (FileStatus, [ScanError 'Parse]))]
-> [(FilePath, FileStatus)] -> [(CanonicalPath, FileStatus)]
gatherFileStatuses = map (second fst) gatherFileStatuses = map (second fst)
processFile :: FilePath -> IO (FileStatus, [ScanError]) processFile :: CanonicalPath -> IO (FileStatus, [ScanError 'Parse])
processFile file = case mscanner file of processFile canonicalFile = case mscanner canonicalFile of
Nothing -> pure (NotScannable, []) Nothing -> pure (NotScannable, [])
Just scanner -> scanner file <&> _1 %~ Scanned Just scanner -> scanner canonicalFile <&> _1 %~ Scanned
----------------------------------------------------------- -----------------------------------------------------------
-- Yaml instances -- Yaml instances

70
src/Xrefcheck/Scanners/Markdown.hs
View File

@ -26,7 +26,6 @@ import Control.Monad.Trans.Writer.CPS (Writer, runWriter, tell)
import Data.Aeson (FromJSON (..), genericParseJSON) import Data.Aeson (FromJSON (..), genericParseJSON)
import Data.ByteString.Lazy qualified as BSL import Data.ByteString.Lazy qualified as BSL
import Data.DList qualified as DList import Data.DList qualified as DList
import Data.Default (def)
import Data.Text qualified as T import Data.Text qualified as T
import Data.Text.Lazy qualified as LT import Data.Text.Lazy qualified as LT
import Fmt (Buildable (..), nameF) import Fmt (Buildable (..), nameF)
@ -35,6 +34,7 @@ import Text.Interpolation.Nyan
import Xrefcheck.Core import Xrefcheck.Core
import Xrefcheck.Scan import Xrefcheck.Scan
import Xrefcheck.System
import Xrefcheck.Util import Xrefcheck.Util
data MarkdownConfig = MarkdownConfig data MarkdownConfig = MarkdownConfig
@ -124,8 +124,6 @@ data GetIgnoreMode
| InvalidMode Text | InvalidMode Text
deriving stock (Eq) deriving stock (Eq)
data ScannerState = ScannerState data ScannerState = ScannerState
{ _ssIgnore :: Maybe Ignore { _ssIgnore :: Maybe Ignore
, _ssParentNodeType :: Maybe NodeType , _ssParentNodeType :: Maybe NodeType
@ -139,7 +137,7 @@ initialScannerState = ScannerState
, _ssParentNodeType = Nothing , _ssParentNodeType = Nothing
} }
type ScannerM a = StateT ScannerState (Writer [ScanError]) a type ScannerM a = StateT ScannerState (Writer [ScanError 'Parse]) a
-- | A fold over a `Node`. -- | A fold over a `Node`.
cataNode :: (Maybe PosInfo -> NodeType -> [c] -> c) -> Node -> c cataNode :: (Maybe PosInfo -> NodeType -> [c] -> c) -> Node -> c
@ -156,9 +154,9 @@ cataNodeWithParentNodeInfo f node = cataNode f' node
map (ssParentNodeType .= Just ty >>) childScanners map (ssParentNodeType .= Just ty >>) childScanners
-- | Find ignore annotations (ignore paragraph and ignore link) -- | Find ignore annotations (ignore paragraph and ignore link)
-- and remove nodes that should be ignored -- and remove nodes that should be ignored.
removeIgnored :: FilePath -> Node -> Writer [ScanError] Node removeIgnored :: Node -> Writer [ScanError 'Parse] Node
removeIgnored fp = withIgnoreMode . cataNodeWithParentNodeInfo remove removeIgnored = withIgnoreMode . cataNodeWithParentNodeInfo remove
where where
remove remove
:: Maybe PosInfo :: Maybe PosInfo
@ -178,7 +176,7 @@ removeIgnored fp = withIgnoreMode . cataNodeWithParentNodeInfo remove
-- found we should report an error. -- found we should report an error.
(IMSParagraph, PARAGRAPH) -> (ssIgnore .= Nothing) $> defNode (IMSParagraph, PARAGRAPH) -> (ssIgnore .= Nothing) $> defNode
(IMSParagraph, x) -> do (IMSParagraph, x) -> do
lift . tell . makeError modePos fp . ParagraphErr $ prettyType x lift . tell . makeError modePos . ParagraphErr $ prettyType x
ssIgnore .= Nothing ssIgnore .= Nothing
Node pos ty <$> sequence subs Node pos ty <$> sequence subs
@ -187,7 +185,7 @@ removeIgnored fp = withIgnoreMode . cataNodeWithParentNodeInfo remove
-- the file should already be ignored when `checkIgnoreFile` is called. -- the file should already be ignored when `checkIgnoreFile` is called.
-- We should report an error if we find it anyway. -- We should report an error if we find it anyway.
(IMSAll, _) -> do (IMSAll, _) -> do
lift . tell $ makeError modePos fp FileErr lift . tell $ makeError modePos FileErr
ssIgnore .= Nothing ssIgnore .= Nothing
Node pos ty <$> sequence subs Node pos ty <$> sequence subs
@ -205,14 +203,14 @@ removeIgnored fp = withIgnoreMode . cataNodeWithParentNodeInfo remove
currentIgnore <- use ssIgnore currentIgnore <- use ssIgnore
case currentIgnore of case currentIgnore of
Just (Ignore {_ignoreMode = IMSLink ParentExpectsLink}) -> do Just (Ignore {_ignoreMode = IMSLink ParentExpectsLink}) -> do
lift $ tell $ makeError modePos fp LinkErr lift $ tell $ makeError modePos LinkErr
ssIgnore .= Nothing ssIgnore .= Nothing
_ -> pass _ -> pass
return node' return node'
when (ty == PARAGRAPH) $ use ssIgnore >>= \case when (ty == PARAGRAPH) $ use ssIgnore >>= \case
Just (Ignore (IMSLink ExpectingLinkInParagraph) pragmaPos) -> Just (Ignore (IMSLink ExpectingLinkInParagraph) pragmaPos) ->
lift $ tell $ makeError pragmaPos fp LinkErr lift $ tell $ makeError pragmaPos LinkErr
_ -> pass _ -> pass
return scan return scan
@ -236,7 +234,7 @@ removeIgnored fp = withIgnoreMode . cataNodeWithParentNodeInfo remove
(ssIgnore .= Just (Ignore ignoreModeState correctPos)) $> defNode (ssIgnore .= Just (Ignore ignoreModeState correctPos)) $> defNode
InvalidMode msg -> do InvalidMode msg -> do
lift . tell $ makeError correctPos fp $ UnrecognisedErr msg lift . tell $ makeError correctPos $ UnrecognisedErr msg
(ssIgnore .= Nothing) $> defNode (ssIgnore .= Nothing) $> defNode
NotAnAnnotation -> Node pos nodeType <$> sequence subs NotAnAnnotation -> Node pos nodeType <$> sequence subs
where where
@ -249,20 +247,20 @@ removeIgnored fp = withIgnoreMode . cataNodeWithParentNodeInfo remove
withIgnoreMode withIgnoreMode
:: ScannerM Node :: ScannerM Node
-> Writer [ScanError] Node -> Writer [ScanError 'Parse] Node
withIgnoreMode action = action `runStateT` initialScannerState >>= \case withIgnoreMode action = action `runStateT` initialScannerState >>= \case
-- We expect `Ignore` state to be `Nothing` when we reach EOF, -- We expect `Ignore` state to be `Nothing` when we reach EOF,
-- otherwise that means there was an annotation that didn't match -- otherwise that means there was an annotation that didn't match
-- any node, so we have to report that. -- any node, so we have to report that.
(node, ScannerState {_ssIgnore = Just (Ignore mode pos)}) -> case mode of (node, ScannerState {_ssIgnore = Just (Ignore mode pos)}) -> case mode of
IMSParagraph -> do IMSParagraph -> do
tell . makeError pos fp $ ParagraphErr "EOF" tell . makeError pos $ ParagraphErr "EOF"
pure node pure node
IMSLink _ -> do IMSLink _ -> do
tell $ makeError pos fp LinkErr tell $ makeError pos LinkErr
pure node pure node
IMSAll -> do IMSAll -> do
tell $ makeError pos fp FileErr tell $ makeError pos FileErr
pure node pure node
(node, _) -> pure node (node, _) -> pure node
@ -273,17 +271,14 @@ foldNode action node@(Node _ _ subs) = do
b <- concatForM subs (foldNode action) b <- concatForM subs (foldNode action)
return (a <> b) return (a <> b)
type ExtractorM a = ReaderT MarkdownConfig (Writer [ScanError]) a type ExtractorM a = ReaderT MarkdownConfig (Writer [ScanError 'Parse]) a
-- | Extract information from source tree. -- | Extract information from source tree.
nodeExtractInfo nodeExtractInfo :: Node -> ExtractorM FileInfo
:: FilePath nodeExtractInfo input@(Node _ _ nSubs) = do
-> Node
-> ExtractorM FileInfo
nodeExtractInfo fp input@(Node _ _ nSubs) = do
if checkIgnoreAllFile nSubs if checkIgnoreAllFile nSubs
then return def then return (diffToFileInfo mempty)
else diffToFileInfo <$> (foldNode extractor =<< lift (removeIgnored fp input)) else diffToFileInfo <$> (foldNode extractor =<< lift (removeIgnored input))
where where
extractor :: Node -> ExtractorM FileInfoDiff extractor :: Node -> ExtractorM FileInfoDiff
@ -332,12 +327,16 @@ nodeExtractInfo fp input@(Node _ _ nSubs) = do
let rName = nodeExtractText node let rName = nodeExtractText node
rPos = toPosition pos rPos = toPosition pos
link = if null url then rName else url link = if null url then rName else url
let (rLink, rAnchor) = case T.splitOn "#" link of let (rLink, rAnchor) = case T.splitOn "#" link of
[t] -> (t, Nothing) [t] -> (t, Nothing)
t : ts -> (t, Just $ T.intercalate "#" ts) t : ts -> (t, Just $ T.intercalate "#" ts)
[] -> error "impossible" [] -> error "impossible"
let rInfo = referenceInfo rLink
return $ FileInfoDiff return $ FileInfoDiff
(DList.singleton $ Reference {rName, rPos, rLink, rAnchor}) (DList.singleton $ Reference {rName, rPos, rLink, rAnchor, rInfo})
DList.empty DList.empty
-- | Check if there is `ignore all` at the beginning of the file, -- | Check if there is `ignore all` at the beginning of the file,
@ -361,10 +360,9 @@ defNode = Node Nothing DOCUMENT [] -- hard-coded default Node
makeError makeError
:: Maybe PosInfo :: Maybe PosInfo
-> FilePath
-> ScanErrorDescription -> ScanErrorDescription
-> [ScanError] -> [ScanError 'Parse]
makeError pos fp errDescription = one $ ScanError (toPosition pos) fp errDescription makeError pos errDescription = one $ mkParseScanError (toPosition pos) errDescription
getCommentContent :: Node -> Maybe Text getCommentContent :: Node -> Maybe Text
getCommentContent node = do getCommentContent node = do
@ -406,16 +404,18 @@ textToMode ("ignore" : [x])
| otherwise = InvalidMode x | otherwise = InvalidMode x
textToMode _ = NotAnAnnotation textToMode _ = NotAnAnnotation
parseFileInfo :: MarkdownConfig -> FilePath -> LT.Text -> (FileInfo, [ScanError]) parseFileInfo :: MarkdownConfig -> LT.Text -> (FileInfo, [ScanError 'Parse])
parseFileInfo config fp input parseFileInfo config input
= runWriter = runWriter
$ flip runReaderT config $ flip runReaderT config
$ nodeExtractInfo fp $ nodeExtractInfo
$ commonmarkToNode [optFootnotes] [extAutolink] $ commonmarkToNode [optFootnotes] [extAutolink]
$ toStrict input $ toStrict input
markdownScanner :: MarkdownConfig -> ScanAction markdownScanner :: MarkdownConfig -> ScanAction
markdownScanner config path = parseFileInfo config path . decodeUtf8 <$> BSL.readFile path markdownScanner config canonicalFile =
parseFileInfo config . decodeUtf8
<$> BSL.readFile (unCanonicalPath canonicalFile)
markdownSupport :: MarkdownConfig -> ([Extension], ScanAction) markdownSupport :: MarkdownConfig -> ([Extension], ScanAction)
markdownSupport config = ([".md"], markdownScanner config) markdownSupport config = ([".md"], markdownScanner config)

157
src/Xrefcheck/System.hs
View File

@ -6,9 +6,20 @@
module Xrefcheck.System module Xrefcheck.System
( readingSystem ( readingSystem
, askWithinCI , askWithinCI
, RelGlobPattern
, CanonicalPath
, canonicalizePath
, unCanonicalPath
, getDirsBetweenRootAndFile
, getPosixRelativeChild
, getPosixRelativeOrAbsoluteChild
, hasIndirectionThroughParent
, takeDirectory
, takeExtension
, (</)
, RelGlobPattern (unRelGlobPattern)
, mkGlobPattern , mkGlobPattern
, normaliseGlobPattern
, bindGlobPattern , bindGlobPattern
, matchesGlobPatterns , matchesGlobPatterns
) where ) where
@ -17,15 +28,14 @@ import Universum
import Data.Aeson (FromJSON (..), withText) import Data.Aeson (FromJSON (..), withText)
import Data.Char qualified as C import Data.Char qualified as C
import Data.Coerce (coerce) import Data.List (stripPrefix)
import GHC.IO.Unsafe (unsafePerformIO) import GHC.IO.Unsafe (unsafePerformIO)
import System.Directory (canonicalizePath) import System.Directory qualified as Directory
import System.Environment (lookupEnv) import System.Environment (lookupEnv)
import System.FilePath qualified as FP
import System.FilePath.Glob qualified as Glob import System.FilePath.Glob qualified as Glob
import System.FilePath.Posix (isRelative, (</>)) import System.FilePath.Posix qualified as FPP
import Text.Interpolation.Nyan import Text.Interpolation.Nyan (int, rmode')
import Xrefcheck.Util (normaliseWithNoTrailing)
-- | We can quite safely treat surrounding filesystem as frozen, -- | We can quite safely treat surrounding filesystem as frozen,
-- so IO reading operations can be turned into pure values. -- so IO reading operations can be turned into pure values.
@ -36,21 +46,125 @@ readingSystem = unsafePerformIO
-- Check the respective env variable which is usually set in all CIs. -- Check the respective env variable which is usually set in all CIs.
askWithinCI :: IO Bool askWithinCI :: IO Bool
askWithinCI = lookupEnv "CI" <&> \case askWithinCI = lookupEnv "CI" <&> \case
Just "1" -> True Just "1" -> True
Just (map C.toLower -> "true") -> True Just (map C.toLower -> "true") -> True
_ -> False _ -> False
-- | Glob pattern relative to repository root. Should be created via @mkGlobPattern@ -- | A FilePath that has been canonicalized.
newtype RelGlobPattern = RelGlobPattern FilePath --
-- It should be created via 'canonicalizePath'.
--
-- Currently, canonical paths have been made absolute, normalised
-- regarding the running platform (e.g. Posix or Windows), with
-- indirections syntactically expanded as much as possible and
-- with no trailing path separator. All this results in a weaker
-- version than that provided by 'System.Directory.canonicalizePath'.
newtype CanonicalPath = UnsafeCanonicalPath
{ unCanonicalPath :: FilePath
} deriving newtype (Show, Eq, Ord)
canonicalizePath :: FilePath -> IO CanonicalPath
canonicalizePath = fmap canonicalize . Directory.makeAbsolute
where
canonicalize :: FilePath -> CanonicalPath
canonicalize = UnsafeCanonicalPath
. expandIndirections
. FP.normalise
. FP.dropTrailingPathSeparator
expandIndirections :: FilePath -> FilePath
expandIndirections = FP.joinPath
. reverse
. expand 0
. reverse
. FP.splitDirectories
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 ".."
-- | 'FilePath.takeDirectory' version for 'CanonicalPath'.
takeDirectory :: CanonicalPath -> CanonicalPath
takeDirectory (UnsafeCanonicalPath p) = UnsafeCanonicalPath $ FP.takeDirectory p
-- | 'FilePath.takeExtension' version for 'CanonicalPath'.
takeExtension :: CanonicalPath -> String
takeExtension (UnsafeCanonicalPath p) = FP.takeExtension p
-- | Get the list of directories, canonicalized, between two given paths.
getDirsBetweenRootAndFile :: CanonicalPath -> CanonicalPath -> [CanonicalPath]
getDirsBetweenRootAndFile (UnsafeCanonicalPath rootPath) file =
case stripPrefix rootPath (unCanonicalPath (takeDirectory file)) of
Just path -> UnsafeCanonicalPath <$> scanl (FP.</>) rootPath directories
where
directories = FP.splitDirectories $ dropWhile FP.isPathSeparator path
Nothing -> []
-- | Get a relative 'FilePath' from the second given path (child) with
-- respect to the first one (root).
--
-- It returns Nothing if child cannot be reached from root downwards
-- in the filesystem tree.
--
-- The resulting `FilePath` uses POSIX path separators.
getPosixRelativeChild :: CanonicalPath -> CanonicalPath -> Maybe FilePath
getPosixRelativeChild (UnsafeCanonicalPath root) (UnsafeCanonicalPath child) =
dropLeadingSepAndEmptyCase . fmap replaceSeparator <$> stripPrefix root child
where
replaceSeparator :: Char -> Char
replaceSeparator c
| FP.isPathSeparator c = FPP.pathSeparator
| otherwise = c
dropLeadingSepAndEmptyCase :: FilePath -> FilePath
dropLeadingSepAndEmptyCase path = case dropWhile FP.isPathSeparator path of
"" -> "."
other -> other
-- | Get the relative 'FilePath' using 'getPosixRelativeChild', but
-- return the same passed absolute path instead of 'Nothing'.
getPosixRelativeOrAbsoluteChild :: CanonicalPath -> CanonicalPath -> FilePath
getPosixRelativeOrAbsoluteChild root child =
fromMaybe (unCanonicalPath child) (getPosixRelativeChild root child)
-- | Check if some 'FilePath' passes through its parent while
-- expanding indirections.
hasIndirectionThroughParent :: FilePath -> Bool
hasIndirectionThroughParent = go 0 . FP.splitDirectories
where
go :: Int -> [FilePath] -> Bool
go _ [] = False
go 0 (".." : _) = True
go acc (".." : xs) = go (acc - 1) xs
go acc ("." : xs) = go acc xs
go acc (_ : xs) = go (acc + 1) xs
-- | Extend some 'CanonicalPath' with a given relative 'FilePath'.
--
-- The right-hand side 'FilePath' can use both Posix and Windows
-- path separators.
(</) :: CanonicalPath -> FilePath -> IO CanonicalPath
UnsafeCanonicalPath p </ f = canonicalizePath $ p FP.</> f
infixr 5 </
-- | Glob pattern relative to repository root.
--
-- It should be created via 'mkGlobPattern'.
newtype RelGlobPattern = UnsafeRelGlobPattern
{ unRelGlobPattern :: FilePath
}
mkGlobPattern :: ToString s => s -> Either String RelGlobPattern mkGlobPattern :: ToString s => s -> Either String RelGlobPattern
mkGlobPattern path = do mkGlobPattern path = do
let spath = toString path let spath = toString path
unless (isRelative spath) $ Left $ unless (FPP.isRelative spath) $ Left $
"Expected a relative glob pattern, but got " <> spath "Expected a relative glob pattern, but got " <> spath
-- Checking correctness of glob, e.g. "a[b" is incorrect -- Checking correctness of glob, e.g. "a[b" is incorrect
case Glob.tryCompileWith globCompileOptions spath of case Glob.tryCompileWith globCompileOptions spath of
Right _ -> return (RelGlobPattern spath) Right _ -> return (UnsafeRelGlobPattern spath)
Left err -> Left Left err -> Left
[int|| [int||
Glob pattern compilation failed. Glob pattern compilation failed.
@ -61,25 +175,20 @@ mkGlobPattern path = do
Special characters in file names can be escaped using square brackets, e.g. <a> -> [<]a[>]. Special characters in file names can be escaped using square brackets, e.g. <a> -> [<]a[>].
|] |]
normaliseGlobPattern :: RelGlobPattern -> RelGlobPattern bindGlobPattern :: CanonicalPath -> RelGlobPattern -> Glob.Pattern
normaliseGlobPattern = RelGlobPattern . normaliseWithNoTrailing . coerce bindGlobPattern root (UnsafeRelGlobPattern relPat) = readingSystem $ do
UnsafeCanonicalPath absPat <- root </ relPat
bindGlobPattern :: FilePath -> RelGlobPattern -> Glob.Pattern
bindGlobPattern root (RelGlobPattern relPat) = readingSystem $ do
-- TODO [#26] try to avoid using canonicalization
absPat <- canonicalizePath (root </> relPat)
case Glob.tryCompileWith globCompileOptions absPat of case Glob.tryCompileWith globCompileOptions absPat of
Left err -> error $ Left err -> error $
"Glob pattern compilation failed after canonicalization: " <> toText err "Glob pattern compilation failed after canonicalization: " <> toText err
Right pat -> Right pat ->
return pat return pat
matchesGlobPatterns :: FilePath -> [RelGlobPattern] -> FilePath -> Bool matchesGlobPatterns :: CanonicalPath -> [RelGlobPattern] -> CanonicalPath -> Bool
matchesGlobPatterns root globPatterns file = or matchesGlobPatterns root globPatterns file = or
[ Glob.match pat cFile [ Glob.match pat $ unCanonicalPath file
| globPattern <- globPatterns | globPattern <- globPatterns
, let pat = bindGlobPattern root globPattern , let pat = bindGlobPattern root globPattern
, let cFile = readingSystem $ canonicalizePath file
] ]
instance FromJSON RelGlobPattern where instance FromJSON RelGlobPattern where

5
src/Xrefcheck/Util.hs
View File

@ -9,7 +9,6 @@ module Xrefcheck.Util
, postfixFields , postfixFields
, (-:) , (-:)
, aesonConfigOption , aesonConfigOption
, normaliseWithNoTrailing
, posixTimeToTimeSecond , posixTimeToTimeSecond
, utcTimeToTimeSecond , utcTimeToTimeSecond
, module Xrefcheck.Util.Colorize , module Xrefcheck.Util.Colorize
@ -27,7 +26,6 @@ import Data.Time (UTCTime)
import Data.Time.Clock (nominalDiffTimeToSeconds) import Data.Time.Clock (nominalDiffTimeToSeconds)
import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds) import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds)
import Fmt (Builder) import Fmt (Builder)
import System.FilePath.Posix (dropTrailingPathSeparator, normalise)
import Time (Second, Time (..), sec) import Time (Second, Time (..), sec)
import Xrefcheck.Util.Colorize import Xrefcheck.Util.Colorize
@ -54,9 +52,6 @@ type family Field f a where
Field Identity a = a Field Identity a = a
Field Maybe a = Maybe a Field Maybe a = Maybe a
normaliseWithNoTrailing :: FilePath -> FilePath
normaliseWithNoTrailing = dropTrailingPathSeparator . normalise
posixTimeToTimeSecond :: POSIXTime -> Time Second posixTimeToTimeSecond :: POSIXTime -> Time Second
posixTimeToTimeSecond posixTime = posixTimeToTimeSecond posixTime =
let picos@(MkFixed ps) = nominalDiffTimeToSeconds posixTime let picos@(MkFixed ps) = nominalDiffTimeToSeconds posixTime

170
src/Xrefcheck/Verify.hs
View File

@ -35,11 +35,15 @@ import Universum
import Control.Concurrent.Async (Async, async, cancel, poll, wait, withAsync) import Control.Concurrent.Async (Async, async, cancel, poll, wait, withAsync)
import Control.Exception (AsyncException (..), throwIO) import Control.Exception (AsyncException (..), throwIO)
import Control.Exception.Safe (handleAsync, handleJust)
import Control.Monad.Except (MonadError (..)) import Control.Monad.Except (MonadError (..))
import Data.Bits (toIntegralSized)
import Data.ByteString qualified as BS import Data.ByteString qualified as BS
import Data.List (lookup)
import Data.List qualified as L import Data.List qualified as L
import Data.Map qualified as M import Data.Map qualified as M
import Data.Reflection (Given) import Data.Reflection (Given)
import Data.Text (toCaseFold)
import Data.Text.Metrics (damerauLevenshteinNorm) import Data.Text.Metrics (damerauLevenshteinNorm)
import Data.Time (UTCTime, defaultTimeLocale, formatTime, readPTime, rfc822DateFormat) import Data.Time (UTCTime, defaultTimeLocale, formatTime, readPTime, rfc822DateFormat)
import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Time.Clock.POSIX (getPOSIXTime)
@ -57,8 +61,8 @@ import Network.HTTP.Req
defaultHttpConfig, ignoreResponse, req, runReq, useURI) defaultHttpConfig, ignoreResponse, req, runReq, useURI)
import Network.HTTP.Types.Header (hRetryAfter) import Network.HTTP.Types.Header (hRetryAfter)
import Network.HTTP.Types.Status (Status, statusCode, statusMessage) import Network.HTTP.Types.Status (Status, statusCode, statusMessage)
import System.FilePath.Posix import System.FilePath (isPathSeparator)
(equalFilePath, joinPath, makeRelative, normalise, splitDirectories, takeDirectory, (</>)) import System.FilePath.Posix ((</>))
import Text.Interpolation.Nyan import Text.Interpolation.Nyan
import Text.ParserCombinators.ReadPrec qualified as ReadPrec (lift) import Text.ParserCombinators.ReadPrec qualified as ReadPrec (lift)
import Text.Regex.TDFA.Text (Regex, regexec) import Text.Regex.TDFA.Text (Regex, regexec)
@ -66,10 +70,6 @@ import Text.URI (Authority (..), ParseExceptionBs, URI (..), mkURIBs)
import Time (RatioNat, Second, Time (..), ms, sec, threadDelay, timeout, (+:+), (-:-)) import Time (RatioNat, Second, Time (..), ms, sec, threadDelay, timeout, (+:+), (-:-))
import URI.ByteString qualified as URIBS import URI.ByteString qualified as URIBS
import Control.Exception.Safe (handleAsync, handleJust)
import Data.Bits (toIntegralSized)
import Data.List (lookup)
import Data.Text (toCaseFold)
import Xrefcheck.Config import Xrefcheck.Config
import Xrefcheck.Core import Xrefcheck.Core
import Xrefcheck.Orphans () import Xrefcheck.Orphans ()
@ -265,7 +265,6 @@ reportVerifyErrs errs = fmt
Invalid references dumped, #{length errs} in total. Invalid references dumped, #{length errs} in total.
|] |]
data RetryAfter = Date UTCTime | Seconds (Time Second) data RetryAfter = Date UTCTime | Seconds (Time Second)
deriving stock (Show, Eq) deriving stock (Show, Eq)
@ -353,19 +352,17 @@ verifyRepo
=> Rewrite => Rewrite
-> Config -> Config
-> VerifyMode -> VerifyMode
-> FilePath
-> RepoInfo -> RepoInfo
-> IO (VerifyResult $ WithReferenceLoc VerifyError) -> IO (VerifyResult $ WithReferenceLoc VerifyError)
verifyRepo verifyRepo
rw rw
config@Config{..} config@Config{..}
mode mode
root repoInfo@RepoInfo{..}
repoInfo'@(RepoInfo files _)
= do = do
let toScan = do let toScan = do
(file, fileInfo) <- M.toList files (file, fileInfo) <- toPairs riFiles
guard . not $ matchesGlobPatterns root (ecIgnoreRefsFrom cExclusions) file guard . not $ matchesGlobPatterns riRoot (ecIgnoreRefsFrom cExclusions) file
case fileInfo of case fileInfo of
Scanned fi -> do Scanned fi -> do
ref <- _fiReferences fi ref <- _fiReferences fi
@ -379,7 +376,7 @@ verifyRepo
accumulated <- loopAsyncUntil (printer progressRef) do accumulated <- loopAsyncUntil (printer progressRef) do
forConcurrentlyCaching toScan ifExternalThenCache $ \(file, ref) -> forConcurrentlyCaching toScan ifExternalThenCache $ \(file, ref) ->
verifyReference config mode progressRef repoInfo' root file ref verifyReference config mode progressRef repoInfo file ref
case accumulated of case accumulated of
Right res -> return $ fold res Right res -> return $ fold res
Left (exception, partialRes) -> do Left (exception, partialRes) -> do
@ -408,11 +405,12 @@ verifyRepo
threadDelay (ms 100) threadDelay (ms 100)
ifExternalThenCache :: (a, Reference) -> NeedsCaching Text ifExternalThenCache :: (a, Reference) -> NeedsCaching Text
ifExternalThenCache (_, Reference{..}) = case locationType rLink of ifExternalThenCache (_, Reference{..}) =
ExternalLoc -> CacheUnderKey rLink if isExternal rInfo
_ -> NoCaching then CacheUnderKey rLink
else NoCaching
shouldCheckLocType :: VerifyMode -> LocationType -> Bool shouldCheckLocType :: VerifyMode -> ReferenceInfo -> Bool
shouldCheckLocType mode locType shouldCheckLocType mode locType
| isExternal locType = shouldCheckExternal mode | isExternal locType = shouldCheckExternal mode
| isLocal locType = shouldCheckLocal mode | isLocal locType = shouldCheckLocal mode
@ -423,29 +421,31 @@ verifyReference
-> VerifyMode -> VerifyMode
-> IORef VerifyProgress -> IORef VerifyProgress
-> RepoInfo -> RepoInfo
-> FilePath -> CanonicalPath
-> FilePath
-> Reference -> Reference
-> IO (VerifyResult $ WithReferenceLoc VerifyError) -> IO (VerifyResult $ WithReferenceLoc VerifyError)
verifyReference verifyReference
config@Config{..} config@Config{..}
mode mode
progressRef progressRef
(RepoInfo files dirs) repoInfo@RepoInfo{..}
root file
fileWithReference
ref@Reference{..} ref@Reference{..}
= retryVerification 0 $ do = retryVerification 0 $
let locType = locationType rLink if shouldCheckLocType mode rInfo
if shouldCheckLocType mode locType then case rInfo of
then case locType of RIFileLocal -> checkRef rAnchor riRoot file ""
FileLocalLoc -> checkRef rAnchor fileWithReference RIFileRelative -> do
RelativeLoc -> checkRef rAnchor let shownFilepath = getPosixRelativeOrAbsoluteChild riRoot (takeDirectory file)
(normalise $ takeDirectory fileWithReference </> toString rLink
</> toString (canonizeLocalRef rLink)) canonicalPath <- takeDirectory file </ toString rLink
AbsoluteLoc -> checkRef rAnchor (root <> toString rLink) checkRef rAnchor riRoot canonicalPath shownFilepath
ExternalLoc -> checkExternalResource config rLink RIFileAbsolute -> do
OtherLoc -> verifying pass let shownFilepath = dropWhile isPathSeparator (toString rLink)
canonicalPath <- riRoot </ shownFilepath
checkRef rAnchor riRoot canonicalPath shownFilepath
RIExternal -> checkExternalResource config rLink
RIOtherProtocol -> verifying pass
else return mempty else return mempty
where where
retryVerification retryVerification
@ -472,7 +472,7 @@ verifyReference
. alterProgressErrors res numberOfRetries . alterProgressErrors res numberOfRetries
atomicModifyIORef' progressRef $ \VerifyProgress{..} -> atomicModifyIORef' progressRef $ \VerifyProgress{..} ->
( if isExternal $ locationType rLink ( if isExternal rInfo
then VerifyProgress{ vrExternal = then VerifyProgress{ vrExternal =
let vrExternalAdvanced = moveProgress vrExternal let vrExternalAdvanced = moveProgress vrExternal
in if toRetry in if toRetry
@ -488,7 +488,8 @@ verifyReference
then do then do
threadDelay currentRetryAfter threadDelay currentRetryAfter
retryVerification (numberOfRetries + 1) resIO retryVerification (numberOfRetries + 1) resIO
else return $ fmap (WithReferenceLoc fileWithReference ref) res else return . (<$> res) $
WithReferenceLoc (getPosixRelativeOrAbsoluteChild riRoot file) ref
alterOverallProgress alterOverallProgress
:: (Num a) :: (Num a)
@ -530,76 +531,51 @@ verifyReference
VerifyResult [ExternalHttpTooManyRequests retryAfter] -> retryAfter VerifyResult [ExternalHttpTooManyRequests retryAfter] -> retryAfter
_ -> Nothing _ -> Nothing
isVirtual = matchesGlobPatterns root (ecIgnoreLocalRefsTo cExclusions) isVirtual canonicalRoot = matchesGlobPatterns canonicalRoot (ecIgnoreLocalRefsTo cExclusions)
checkRef mAnchor referredFile = verifying $ -- Checks a local file reference.
unless (isVirtual referredFile) do --
checkReferredFileIsInsideRepo referredFile -- The `shownFilepath` argument is intended to be shown in the error
mFileStatus <- tryGetFileStatus referredFile -- report when the `referredFile` path is not a child of `canonicalRoot`,
-- so it allows indirections and should be suitable for being shown to
-- the user. Also, it will be considered as outside the repository if
-- it is relative and its idirections pass through the repository root.
checkRef mAnchor canonicalRoot referredFile shownFilepath = verifying $
unless (isVirtual canonicalRoot referredFile) do
when (hasIndirectionThroughParent shownFilepath) $
throwError $ LocalFileOutsideRepo shownFilepath
referredFileRelative <-
case getPosixRelativeChild canonicalRoot referredFile of
Just ps -> pure ps
Nothing -> throwError (LocalFileOutsideRepo shownFilepath)
mFileStatus <- tryGetFileStatus referredFileRelative referredFile
case mFileStatus of case mFileStatus of
Right (Scanned referredFileInfo) -> whenJust mAnchor $ Right (Scanned referredFileInfo) -> whenJust mAnchor $
checkAnchor referredFile (_fiAnchors referredFileInfo) checkAnchor referredFileRelative (_fiAnchors referredFileInfo)
Right NotScannable -> pass -- no support for such file, can do nothing Right NotAddedToGit -> throwError (LinkTargetNotAddedToGit referredFileRelative)
Right NotAddedToGit -> throwError (LinkTargetNotAddedToGit referredFile) Left UntrackedDirectory -> throwError (LinkTargetNotAddedToGit referredFileRelative)
Left UntrackedDirectory -> throwError (LinkTargetNotAddedToGit referredFile) Right NotScannable -> pass -- no support for such file, can do nothing
Left TrackedDirectory -> pass -- path leads to directory, currently Left TrackedDirectory -> pass -- path leads to directory, currently
-- if such link contain anchor, we ignore it -- if such link contain anchor, we ignore it
-- expands ".." and "." caseInsensitive = caseInsensitiveAnchors . mcFlavor . scMarkdown $ cScanners
-- 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
-- Returns `Nothing` when path corresponds to an existing (and tracked) directory -- Returns `Nothing` when path corresponds to an existing (and tracked) directory
tryGetFileStatus :: FilePath -> ExceptT VerifyError IO (Either DirectoryStatus FileStatus) tryGetFileStatus :: FilePath -> CanonicalPath -> ExceptT VerifyError IO (Either DirectoryStatus FileStatus)
tryGetFileStatus file tryGetFileStatus filePath canonicalPath
| Just f <- mFile = return $ Right f | Just f <- lookupFile canonicalPath repoInfo = return (Right f)
| Just d <- mDir = return $ Left d | Just d <- lookupDirectory canonicalPath repoInfo = return (Left d)
| otherwise = throwError (LocalFileDoesNotExist file) | otherwise = throwError (LocalFileDoesNotExist filePath)
where
matchesFilePath :: FilePath -> Bool
matchesFilePath = equalFilePath $ expandIndirections file
mFile :: Maybe FileStatus checkAnchor filePath fileAnchors anchor = do
mFile = (files M.!) <$> find matchesFilePath (M.keys files) checkAnchorReferenceAmbiguity filePath fileAnchors anchor
checkDeduplicatedAnchorReference filePath fileAnchors anchor
mDir :: Maybe DirectoryStatus
mDir = (dirs M.!) <$> find matchesFilePath (M.keys dirs)
checkAnchor file fileAnchors anchor = do
checkAnchorReferenceAmbiguity file fileAnchors anchor
checkDeduplicatedAnchorReference file fileAnchors anchor
checkAnchorExists fileAnchors anchor checkAnchorExists fileAnchors anchor
anchorNameEq = anchorNameEq =
if caseInsensitiveAnchors . mcFlavor . scMarkdown $ cScanners if caseInsensitive
then (==) `on` toCaseFold then (==) `on` toCaseFold
else (==) else (==)
@ -607,16 +583,16 @@ verifyReference
-- has added a suffix to the duplicate, and now the original is referrenced - -- has added a suffix to the duplicate, and now the original is referrenced -
-- such links are pretty fragile and we discourage their use despite -- such links are pretty fragile and we discourage their use despite
-- they are in fact unambiguous. -- they are in fact unambiguous.
checkAnchorReferenceAmbiguity file fileAnchors anchor = do checkAnchorReferenceAmbiguity filePath fileAnchors anchor = do
let similarAnchors = filter (anchorNameEq anchor . aName) fileAnchors let similarAnchors = filter (anchorNameEq anchor . aName) fileAnchors
when (length similarAnchors > 1) $ when (length similarAnchors > 1) $
throwError $ AmbiguousAnchorRef file anchor (Exts.fromList similarAnchors) throwError $ AmbiguousAnchorRef filePath anchor (Exts.fromList similarAnchors)
-- Similar to the previous one, but for the case when we reference the -- Similar to the previous one, but for the case when we reference the
-- renamed duplicate. -- renamed duplicate.
checkDeduplicatedAnchorReference file fileAnchors anchor = checkDeduplicatedAnchorReference filePath fileAnchors anchor =
whenJust (stripAnchorDupNo anchor) $ \origAnchor -> whenJust (stripAnchorDupNo anchor) $ \origAnchor ->
checkAnchorReferenceAmbiguity file fileAnchors origAnchor checkAnchorReferenceAmbiguity filePath fileAnchors origAnchor
checkAnchorExists givenAnchors anchor = checkAnchorExists givenAnchors anchor =
case find (anchorNameEq anchor . aName) givenAnchors of case find (anchorNameEq anchor . aName) givenAnchors of

63
tests/Test/Xrefcheck/CanonicalPathSpec.hs Normal file
View File

@ -0,0 +1,63 @@
{- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io>
-
- SPDX-License-Identifier: MPL-2.0
-}
module Test.Xrefcheck.CanonicalPathSpec where
import Universum
import System.Directory (getCurrentDirectory)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase, (@?=))
import Xrefcheck.System
test_canonicalPath :: IO TestTree
test_canonicalPath = do
current <- getCurrentDirectory >>= canonicalizePath
return $ testGroup "Canonical paths"
[ testGroup "Canonicalization"
[ testCase "Trailing separator" $ do
path <- canonicalizePath "./example/dir/"
getPosixRelativeOrAbsoluteChild current path @?= "example/dir"
, testCase "Parent directory indirection" $ do
path <- canonicalizePath "dir1/../dir2"
getPosixRelativeOrAbsoluteChild current path @?= "dir2"
, testCase "Through parent directory indirection" $ do
path <- canonicalizePath "dir1/../../../dir2"
root <- current </ "../.."
getPosixRelativeOrAbsoluteChild root path @?= "dir2"
, testCase "Current directory indirection" $ do
path <- canonicalizePath "././dir1/./././dir2/././"
getPosixRelativeOrAbsoluteChild current path @?= "dir1/dir2"
, testCase "Mixed indirections result in current directory" $ do
path <- canonicalizePath "././dir1/./.././dir2/./../"
getPosixRelativeOrAbsoluteChild current path @?= "."
]
, testGroup "Relative path"
[ testCase "Child directory" $ do
path <- canonicalizePath "./dir1/dir2/"
getPosixRelativeChild current path @?= Just ("dir1/dir2")
, testCase "Not a child directory" $ do
root <- canonicalizePath "./dir1/dir2/"
path <- canonicalizePath "./dir1/dir3/"
getPosixRelativeChild root path @?= Nothing
]
, testGroup "Intermediate directories"
[ testCase "No intermediate directories same" $ do
path <- canonicalizePath "./dir1/dir3/"
getDirsBetweenRootAndFile path path @?= []
, testCase "No intermediate directories different" $ do
root <- canonicalizePath "./dir1/dir2/"
path <- canonicalizePath "./dir1/dir3/"
getDirsBetweenRootAndFile root path @?= []
, testCase "Intermediate directories" $ do
path <- canonicalizePath "./example/dir/other"
getPosixRelativeOrAbsoluteChild current <$> getDirsBetweenRootAndFile current path @?=
[ "."
, "example"
, "example/dir"
]
]
]

12
tests/Test/Xrefcheck/IgnoreAnnotationsSpec.hs
View File

@ -22,19 +22,19 @@ test_ignoreAnnotations =
[ testCase "Check if broken link annotation produce error" do [ testCase "Check if broken link annotation produce error" do
let file = "tests/markdowns/with-annotations/no_link.md" let file = "tests/markdowns/with-annotations/no_link.md"
errs <- getErrs file errs <- getErrs file
errs @?= makeError (Just $ PosInfo 7 1 7 31) file LinkErr errs @?= makeError (Just $ PosInfo 7 1 7 31) LinkErr
, testCase "Check if broken paragraph annotation produce error" do , testCase "Check if broken paragraph annotation produce error" do
let file = "tests/markdowns/with-annotations/no_paragraph.md" let file = "tests/markdowns/with-annotations/no_paragraph.md"
errs <- getErrs file errs <- getErrs file
errs @?= makeError (Just $ PosInfo 7 1 7 35) file (ParagraphErr "HEADING") errs @?= makeError (Just $ PosInfo 7 1 7 35) (ParagraphErr "HEADING")
, testCase "Check if broken ignore all annotation produce error" do , testCase "Check if broken ignore all annotation produce error" do
let file = "tests/markdowns/with-annotations/unexpected_ignore_file.md" let file = "tests/markdowns/with-annotations/unexpected_ignore_file.md"
errs <- getErrs file errs <- getErrs file
errs @?= makeError (Just $ PosInfo 9 1 9 29) file FileErr errs @?= makeError (Just $ PosInfo 9 1 9 29) FileErr
, testCase "Check if broken unrecognised annotation produce error" do , testCase "Check if broken unrecognised annotation produce error" do
let file = "tests/markdowns/with-annotations/unrecognised_option.md" let file = "tests/markdowns/with-annotations/unrecognised_option.md"
errs <- getErrs file errs <- getErrs file
errs @?= makeError (Just $ PosInfo 7 1 7 46) file (UnrecognisedErr "unrecognised-option") errs @?= makeError (Just $ PosInfo 7 1 7 46) (UnrecognisedErr "unrecognised-option")
] ]
, testGroup "\"ignore link\" mode" , testGroup "\"ignore link\" mode"
[ testCase "Check \"ignore link\" performance" $ do [ testCase "Check \"ignore link\" performance" $ do
@ -42,7 +42,7 @@ test_ignoreAnnotations =
(fi, errs) <- parse GitHub file (fi, errs) <- parse GitHub file
getRefs fi @?= getRefs fi @?=
["team", "team", "team", "hire-us", "how-we-work", "privacy", "link2", "link2", "link3"] ["team", "team", "team", "hire-us", "how-we-work", "privacy", "link2", "link2", "link3"]
errs @?= makeError (Just $ PosInfo 42 1 42 31) file LinkErr errs @?= makeError (Just $ PosInfo 42 1 42 31) LinkErr
] ]
, testGroup "\"ignore paragraph\" mode" , testGroup "\"ignore paragraph\" mode"
[ testCase "Check \"ignore paragraph\" performance" $ do [ testCase "Check \"ignore paragraph\" performance" $ do
@ -61,5 +61,5 @@ test_ignoreAnnotations =
getRefs :: FileInfo -> [Text] getRefs :: FileInfo -> [Text]
getRefs fi = map rName $ fi ^. fiReferences getRefs fi = map rName $ fi ^. fiReferences
getErrs :: FilePath -> IO [ScanError] getErrs :: FilePath -> IO [ScanError 'Parse]
getErrs path = snd <$> parse GitHub path getErrs path = snd <$> parse GitHub path

2
tests/Test/Xrefcheck/IgnoreRegexSpec.hs
View File

@ -42,7 +42,7 @@ test_ignoreRegex = give WithoutColors $
scanRepo OnlyTracked rw formats (config ^. cExclusionsL) root scanRepo OnlyTracked rw formats (config ^. cExclusionsL) root
verifyRes <- allowRewrite showProgressBar $ \rw -> verifyRes <- allowRewrite showProgressBar $ \rw ->
verifyRepo rw config verifyMode root $ srRepoInfo scanResult verifyRepo rw config verifyMode $ srRepoInfo scanResult
let brokenLinks = pickBrokenLinks verifyRes let brokenLinks = pickBrokenLinks verifyRes

25
tests/Test/Xrefcheck/LocalSpec.hs
View File

@ -1,25 +0,0 @@
{- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>
-
- SPDX-License-Identifier: MPL-2.0
-}
module Test.Xrefcheck.LocalSpec where
import Universum
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase, (@?=))
import Xrefcheck.Core (canonizeLocalRef)
test_local_refs_canonizing :: TestTree
test_local_refs_canonizing = testGroup "Local refs canonizing" $
[ testCase "Strips ./" $
canonizeLocalRef "./AnchorsSpec.hs" @?= "AnchorsSpec.hs"
, testCase "Strips ././" $
canonizeLocalRef "././AnchorsSpec.hs" @?= "AnchorsSpec.hs"
, testCase "Leaves plain other intact" $
canonizeLocalRef "../AnchorsSpec.hs" @?= "../AnchorsSpec.hs"
]

2
tests/Test/Xrefcheck/RedirectRequestsSpec.hs
View File

@ -1,4 +1,4 @@
{- SPDX-FileCopyrightText: 2021 Serokell <https://serokell.io> {- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io>
- -
- SPDX-License-Identifier: MPL-2.0 - SPDX-License-Identifier: MPL-2.0
-} -}

6
tests/Test/Xrefcheck/TooManyRequestsSpec.hs
View File

@ -63,7 +63,7 @@ test_tooManyRequests = testGroup "429 response tests"
} }
} }
_ <- verifyReferenceWithProgress _ <- verifyReferenceWithProgress
(Reference "" "http://127.0.0.1:5000/429" Nothing (Position Nothing)) (Reference "" "http://127.0.0.1:5000/429" Nothing (Position Nothing) RIExternal)
progressRef progressRef
Progress{..} <- vrExternal <$> readIORef progressRef Progress{..} <- vrExternal <$> readIORef progressRef
let ttc = ttTimeToCompletion <$> pTaskTimestamp let ttc = ttTimeToCompletion <$> pTaskTimestamp
@ -88,7 +88,7 @@ test_tooManyRequests = testGroup "429 response tests"
} }
} }
_ <- verifyReferenceWithProgress _ <- verifyReferenceWithProgress
(Reference "" "http://127.0.0.1:5000/429" Nothing (Position Nothing)) (Reference "" "http://127.0.0.1:5000/429" Nothing (Position Nothing) RIExternal)
progressRef progressRef
Progress{..} <- vrExternal <$> readIORef progressRef Progress{..} <- vrExternal <$> readIORef progressRef
let ttc = fromMaybe (sec 0) $ ttTimeToCompletion <$> pTaskTimestamp let ttc = fromMaybe (sec 0) $ ttTimeToCompletion <$> pTaskTimestamp
@ -114,7 +114,7 @@ test_tooManyRequests = testGroup "429 response tests"
} }
} }
_ <- verifyReferenceWithProgress _ <- verifyReferenceWithProgress
(Reference "" "http://127.0.0.1:5000/429" Nothing (Position Nothing)) (Reference "" "http://127.0.0.1:5000/429" Nothing (Position Nothing) RIExternal)
progressRef progressRef
Progress{..} <- vrExternal <$> readIORef progressRef Progress{..} <- vrExternal <$> readIORef progressRef
let ttc = ttTimeToCompletion <$> pTaskTimestamp let ttc = ttTimeToCompletion <$> pTaskTimestamp

9
tests/Test/Xrefcheck/TrailingSlashSpec.hs
View File

@ -17,6 +17,7 @@ import Xrefcheck.Core
import Xrefcheck.Progress import Xrefcheck.Progress
import Xrefcheck.Scan import Xrefcheck.Scan
import Xrefcheck.Scanners.Markdown import Xrefcheck.Scanners.Markdown
import Xrefcheck.System
import Xrefcheck.Util import Xrefcheck.Util
test_slash :: TestTree test_slash :: TestTree
@ -27,13 +28,13 @@ test_slash = testGroup "Trailing forward slash detection" $
testCase ("All the files within the root \"" <> testCase ("All the files within the root \"" <>
root <> root <>
"\" should exist") $ do "\" should exist") $ do
(ScanResult _ (RepoInfo repoInfo _)) <- allowRewrite False $ \rw -> (ScanResult _ RepoInfo{..}) <- allowRewrite False $ \rw ->
scanRepo OnlyTracked rw format (cExclusions config & ecIgnoreL .~ []) root scanRepo OnlyTracked rw format (cExclusions config & ecIgnoreL .~ []) root
nonExistentFiles <- lefts <$> forM (keys repoInfo) (\filePath -> do nonExistentFiles <- lefts <$> forM (fst <$> toPairs riFiles) (\filePath -> do
predicate <- doesFileExist filePath predicate <- doesFileExist . unCanonicalPath $ filePath
return $ if predicate return $ if predicate
then Right () then Right ()
else Left filePath) else Left . unCanonicalPath $ filePath)
whenJust (nonEmpty nonExistentFiles) $ \files -> whenJust (nonEmpty nonExistentFiles) $ \files ->
assertFailure assertFailure
[int|| [int||

9
tests/Test/Xrefcheck/Util.hs
View File

@ -11,11 +11,14 @@ import Network.HTTP.Types (forbidden403, unauthorized401)
import Web.Firefly (ToResponse (..), route, run) import Web.Firefly (ToResponse (..), route, run)
import Xrefcheck.Core (FileInfo, Flavor) import Xrefcheck.Core (FileInfo, Flavor)
import Xrefcheck.Scan (ScanError) import Xrefcheck.Scan (ScanError, ScanStage (..))
import Xrefcheck.Scanners.Markdown (MarkdownConfig (MarkdownConfig, mcFlavor), markdownScanner) import Xrefcheck.Scanners.Markdown (MarkdownConfig (MarkdownConfig, mcFlavor), markdownScanner)
import Xrefcheck.System (canonicalizePath)
parse :: Flavor -> FilePath -> IO (FileInfo, [ScanError]) parse :: Flavor -> FilePath -> IO (FileInfo, [ScanError 'Parse])
parse fl path = markdownScanner MarkdownConfig { mcFlavor = fl } path parse fl path = do
canonicalPath <- canonicalizePath path
markdownScanner MarkdownConfig { mcFlavor = fl } canonicalPath
mockServer :: IO () mockServer :: IO ()
mockServer = run 3000 $ do mockServer = run 3000 $ do

8
tests/Test/Xrefcheck/UtilRequests.hs
View File

@ -12,7 +12,6 @@ module Test.Xrefcheck.UtilRequests
import Universum import Universum
import Control.Exception qualified as E import Control.Exception qualified as E
import Data.Map qualified as M
import Text.Interpolation.Nyan import Text.Interpolation.Nyan
import Control.Concurrent (forkIO, killThread) import Control.Concurrent (forkIO, killThread)
@ -21,6 +20,7 @@ import Xrefcheck.Config
import Xrefcheck.Core import Xrefcheck.Core
import Xrefcheck.Progress import Xrefcheck.Progress
import Xrefcheck.Scan import Xrefcheck.Scan
import Xrefcheck.System (canonicalizePath)
import Xrefcheck.Util import Xrefcheck.Util
import Xrefcheck.Verify import Xrefcheck.Verify
@ -62,7 +62,7 @@ checkLinkAndProgressWithServer mock link progress vrExpectation =
verifyLink :: Text -> IO (VerifyResult VerifyError, Progress Int) verifyLink :: Text -> IO (VerifyResult VerifyError, Progress Int)
verifyLink link = do verifyLink link = do
let reference = Reference "" link Nothing (Position Nothing) let reference = Reference "" link Nothing (Position Nothing) RIExternal
progRef <- newIORef $ initVerifyProgress [reference] progRef <- newIORef $ initVerifyProgress [reference]
result <- verifyReferenceWithProgress reference progRef result <- verifyReferenceWithProgress reference progRef
p <- readIORef progRef p <- readIORef progRef
@ -70,6 +70,8 @@ verifyLink link = do
verifyReferenceWithProgress :: Reference -> IORef VerifyProgress -> IO (VerifyResult VerifyError) verifyReferenceWithProgress :: Reference -> IORef VerifyProgress -> IO (VerifyResult VerifyError)
verifyReferenceWithProgress reference progRef = do verifyReferenceWithProgress reference progRef = do
canonicalRoot <- canonicalizePath "."
file <- canonicalizePath ""
fmap wrlItem <$> verifyReference fmap wrlItem <$> verifyReference
(defConfig GitHub & cExclusionsL . ecIgnoreExternalRefsToL .~ []) FullMode (defConfig GitHub & cExclusionsL . ecIgnoreExternalRefsToL .~ []) FullMode
progRef (RepoInfo M.empty mempty) "." "" reference progRef (RepoInfo mempty mempty canonicalRoot) file reference

14
tests/golden/check-anchors/check-anchors.bats
View File

@ -14,14 +14,14 @@ load '../helpers'
assert_diff - <<EOF assert_diff - <<EOF
=== Invalid references found === === Invalid references found ===
➥ In file ambiguous-anchors/a.md ➥ In file a.md
bad reference (file-local) at src:16:1-43: bad reference (file-local) at src:16:1-43:
- text: "ambiguous anchor in this file" - text: "ambiguous anchor in this file"
- link: - - link: -
- anchor: some-text - anchor: some-text
Ambiguous reference to anchor 'some-text' Ambiguous reference to anchor 'some-text'
In file ambiguous-anchors/a.md In file a.md
It could refer to either: It could refer to either:
- some-text (header I) at src:6:1-11 - some-text (header I) at src:6:1-11
- some-text (header I) at src:8:1-15 - some-text (header I) at src:8:1-15
@ -29,14 +29,14 @@ assert_diff - <<EOF
Use of ambiguous anchors is discouraged because the target Use of ambiguous anchors is discouraged because the target
can change silently while the document containing it evolves. can change silently while the document containing it evolves.
➥ In file ambiguous-anchors/b.md ➥ In file b.md
bad reference (relative) at src:7:1-48: bad reference (relative) at src:7:1-48:
- text: "ambiguous anchor in other file" - text: "ambiguous anchor in other file"
- link: a.md - link: a.md
- anchor: some-text - anchor: some-text
Ambiguous reference to anchor 'some-text' Ambiguous reference to anchor 'some-text'
In file ambiguous-anchors/a.md In file a.md
It could refer to either: It could refer to either:
- some-text (header I) at src:6:1-11 - some-text (header I) at src:6:1-11
- some-text (header I) at src:8:1-15 - some-text (header I) at src:8:1-15
@ -53,7 +53,7 @@ EOF
assert_diff - <<EOF assert_diff - <<EOF
=== Invalid references found === === Invalid references found ===
➥ In file non-existing-anchors/a.md ➥ In file a.md
bad reference (file-local) at src:12:1-13: bad reference (file-local) at src:12:1-13:
- text: "broken" - text: "broken"
- link: - - link: -
@ -63,7 +63,7 @@ assert_diff - <<EOF
- h1 (header I) at src:6:1-4 - h1 (header I) at src:6:1-4
- h2 (header II) at src:8:1-5 - h2 (header II) at src:8:1-5
➥ In file non-existing-anchors/a.md ➥ In file a.md
bad reference (file-local) at src:14:1-18: bad reference (file-local) at src:14:1-18:
- text: "broken" - text: "broken"
- link: - - link: -
@ -72,7 +72,7 @@ assert_diff - <<EOF
Anchor 'heading' is not present, did you mean: Anchor 'heading' is not present, did you mean:
- the-heading (header I) at src:10:1-13 - the-heading (header I) at src:10:1-13
➥ In file non-existing-anchors/a.md ➥ In file a.md
bad reference (file-local) at src:16:1-31: bad reference (file-local) at src:16:1-31:
- text: "broken" - text: "broken"
- link: - - link: -

6
tests/golden/check-cli/check-cli.bats
View File

@ -54,7 +54,7 @@ load '../helpers'
- anchor: - - anchor: -
File does not exist: File does not exist:
./one/two/three one/two/three
Invalid references dumped, 1 in total. Invalid references dumped, 1 in total.
EOF EOF
@ -73,7 +73,7 @@ EOF
- anchor: - - anchor: -
File does not exist: File does not exist:
./one/two/three one/two/three
Invalid references dumped, 1 in total. Invalid references dumped, 1 in total.
EOF EOF
@ -92,7 +92,7 @@ EOF
- anchor: - - anchor: -
File does not exist: File does not exist:
./one/two/three one/two/three
Invalid references dumped, 1 in total. Invalid references dumped, 1 in total.
EOF EOF

4
tests/golden/check-footnotes/expected.gold
View File

@ -1,12 +1,12 @@
=== Invalid references found === === Invalid references found ===
➥ In file broken-link-in-footnote/file-with-footnote-with-broken-link.md ➥ In file file-with-footnote-with-broken-link.md
bad reference (relative) at src:8:9-43: bad reference (relative) at src:8:9-43:
- text: "bad link in footnote" - text: "bad link in footnote"
- link: ./notExists - link: ./notExists
- anchor: - - anchor: -
File does not exist: File does not exist:
broken-link-in-footnote/notExists notExists
Invalid references dumped, 1 in total. Invalid references dumped, 1 in total.

2
tests/golden/check-ignore/check-ignore.bats
View File

@ -71,7 +71,7 @@ Scan errors dumped, 1 in total.
- anchor: - - anchor: -
File does not exist: File does not exist:
./referenced-file.md referenced-file.md
Invalid references dumped, 1 in total. Invalid references dumped, 1 in total.
EOF EOF

12
tests/golden/check-ignoreLocalRefsTo/expected.gold
View File

@ -7,7 +7,7 @@
- anchor: - - anchor: -
File does not exist: File does not exist:
./one/a.md one/a.md
➥ In file check-ignoreLocalRefsTo.md ➥ In file check-ignoreLocalRefsTo.md
bad reference (absolute) at src:9:1-26: bad reference (absolute) at src:9:1-26:
@ -16,7 +16,7 @@
- anchor: - - anchor: -
File does not exist: File does not exist:
./two/b.md two/b.md
➥ In file check-ignoreLocalRefsTo.md ➥ In file check-ignoreLocalRefsTo.md
bad reference (absolute) at src:11:1-39: bad reference (absolute) at src:11:1-39:
@ -25,7 +25,7 @@
- anchor: - - anchor: -
File does not exist: File does not exist:
./three/c.md three/c.md
➥ In file check-ignoreLocalRefsTo.md ➥ In file check-ignoreLocalRefsTo.md
bad reference (absolute) at src:13:1-51: bad reference (absolute) at src:13:1-51:
@ -34,7 +34,7 @@
- anchor: - - anchor: -
File does not exist: File does not exist:
./three/four/d.md three/four/d.md
➥ In file check-ignoreLocalRefsTo.md ➥ In file check-ignoreLocalRefsTo.md
bad reference (absolute) at src:15:1-59: bad reference (absolute) at src:15:1-59:
@ -43,7 +43,7 @@
- anchor: - - anchor: -
File does not exist: File does not exist:
./three/five/e.md three/five/e.md
➥ In file one/file.md ➥ In file one/file.md
bad reference (relative) at src:7:1-58: bad reference (relative) at src:7:1-58:
@ -61,6 +61,6 @@
- anchor: - - anchor: -
File does not exist: File does not exist:
one/../two/b.md two/b.md
Invalid references dumped, 7 in total. Invalid references dumped, 7 in total.

2
tests/golden/check-ignoreRefsFrom/check-ignoreRefsFrom.bats
View File

@ -41,7 +41,7 @@ load '../helpers'
- anchor: - - anchor: -
File does not exist: File does not exist:
./no-file.md no-file.md
Invalid references dumped, 1 in total. Invalid references dumped, 1 in total.
EOF EOF

20
tests/golden/check-local-refs/expected1.gold
View File

@ -15,7 +15,7 @@
- anchor: - - anchor: -
File does not exist: File does not exist:
dir1/dir2/../a/b/c/unexisting-file.md dir1/a/b/c/unexisting-file.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir1/dir2/d2f1.md
bad reference (relative) at src:28:1-31: bad reference (relative) at src:28:1-31:
@ -24,7 +24,7 @@
- anchor: - - anchor: -
File does not exist: File does not exist:
dir1/dir2/D2F2.md/ dir1/dir2/D2F2.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir1/dir2/d2f1.md
bad reference (relative) at src:29:1-32: bad reference (relative) at src:29:1-32:
@ -33,7 +33,7 @@
- anchor: - - anchor: -
File does not exist: File does not exist:
dir1/dir2/../DIR2 dir1/DIR2
➥ In file dir1/dir2/d2f1.md ➥ In file dir1/dir2/d2f1.md
bad reference (relative) at src:31:1-38: bad reference (relative) at src:31:1-38:
@ -59,7 +59,7 @@
- anchor: - - anchor: -
File does not exist: File does not exist:
./d1f1.md d1f1.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir1/dir2/d2f1.md
bad reference (absolute) at src:43:1-27: bad reference (absolute) at src:43:1-27:
@ -68,7 +68,7 @@
- anchor: - - anchor: -
File does not exist: File does not exist:
./dir2/d2f2.md dir2/d2f2.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir1/dir2/d2f1.md
bad reference (absolute) at src:44:1-32: bad reference (absolute) at src:44:1-32:
@ -77,7 +77,7 @@
- anchor: - - anchor: -
File does not exist: File does not exist:
././dir2/../d1f1.md d1f1.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir1/dir2/d2f1.md
bad reference (absolute) at src:45:1-37: bad reference (absolute) at src:45:1-37:
@ -86,7 +86,7 @@
- anchor: - - anchor: -
File does not exist: File does not exist:
././dir2/../d1f1.md/ d1f1.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir1/dir2/d2f1.md
bad reference (absolute) at src:46:1-55: bad reference (absolute) at src:46:1-55:
@ -95,7 +95,7 @@
- anchor: existing-anchor-d1f1 - anchor: existing-anchor-d1f1
File does not exist: File does not exist:
././dir2/../d1f1.md d1f1.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir1/dir2/d2f1.md
bad reference (absolute) at src:57:1-16: bad reference (absolute) at src:57:1-16:
@ -104,7 +104,7 @@
- anchor: - - anchor: -
Link targets a local file outside repository: Link targets a local file outside repository:
./../../a.md ../../a.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir1/dir2/d2f1.md
bad reference (absolute) at src:58:1-18: bad reference (absolute) at src:58:1-18:
@ -113,6 +113,6 @@
- anchor: - - anchor: -
Link targets a local file outside repository: Link targets a local file outside repository:
./b/../../b.md b/../../b.md
Invalid references dumped, 13 in total. Invalid references dumped, 13 in total.

60
tests/golden/check-local-refs/expected2.gold
View File

@ -1,6 +1,6 @@
=== Invalid references found === === Invalid references found ===
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (file-local) at src:9:1-18: bad reference (file-local) at src:9:1-18:
- text: "bad-cf-ref" - text: "bad-cf-ref"
- link: - - link: -
@ -8,34 +8,34 @@
Anchor 'bad' is not present Anchor 'bad' is not present
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (relative) at src:27:1-43: bad reference (relative) at src:27:1-43:
- text: "bad-file-rel" - text: "bad-file-rel"
- link: ../a/b/c/unexisting-file.md - link: ../a/b/c/unexisting-file.md
- anchor: - - anchor: -
File does not exist: File does not exist:
dir1/dir2/../a/b/c/unexisting-file.md a/b/c/unexisting-file.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (relative) at src:28:1-31: bad reference (relative) at src:28:1-31:
- text: "bad-casing-file-rel" - text: "bad-casing-file-rel"
- link: D2F2.md/ - link: D2F2.md/
- anchor: - - anchor: -
File does not exist: File does not exist:
dir1/dir2/D2F2.md/ dir2/D2F2.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (relative) at src:29:1-32: bad reference (relative) at src:29:1-32:
- text: "bad-casing-folder-rel" - text: "bad-casing-folder-rel"
- link: ../DIR2 - link: ../DIR2
- anchor: - - anchor: -
File does not exist: File does not exist:
dir1/dir2/../DIR2 DIR2
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (relative) at src:31:1-38: bad reference (relative) at src:31:1-38:
- text: "bad-anchor-rel-1" - text: "bad-anchor-rel-1"
- link: d2f2.md - link: d2f2.md
@ -43,103 +43,103 @@
Anchor 'bad-anchor' is not present Anchor 'bad-anchor' is not present
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (relative) at src:32:1-49: bad reference (relative) at src:32:1-49:
- text: "bad-anchor-rel-2" - text: "bad-anchor-rel-2"
- link: unexisting-file.md - link: unexisting-file.md
- anchor: bad-anchor - anchor: bad-anchor
File does not exist: File does not exist:
dir1/dir2/unexisting-file.md dir2/unexisting-file.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (absolute) at src:36:1-29: bad reference (absolute) at src:36:1-29:
- text: "file-abs-1" - text: "file-abs-1"
- link: /dir1/./d1f1.md - link: /dir1/./d1f1.md
- anchor: - - anchor: -
File does not exist: File does not exist:
dir1/dir1/./d1f1.md dir1/d1f1.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (absolute) at src:37:1-21: bad reference (absolute) at src:37:1-21:
- text: "folder-abs-1" - text: "folder-abs-1"
- link: /dir1 - link: /dir1
- anchor: - - anchor: -
File does not exist: File does not exist:
dir1/dir1 dir1
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (absolute) at src:38:1-30: bad reference (absolute) at src:38:1-30:
- text: "folder-abs-2" - text: "folder-abs-2"
- link: /dir1/dir2/../ - link: /dir1/dir2/../
- anchor: - - anchor: -
File does not exist: File does not exist:
dir1/dir1/dir2/../ dir1
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (absolute) at src:39:1-58: bad reference (absolute) at src:39:1-58:
- text: "anchor-abs-1" - text: "anchor-abs-1"
- link: /dir1/../dir1/d1f1.md - link: /dir1/../dir1/d1f1.md
- anchor: existing-anchor-d1f1 - anchor: existing-anchor-d1f1
File does not exist: File does not exist:
dir1/dir1/../dir1/d1f1.md dir1/d1f1.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (absolute) at src:40:1-73: bad reference (absolute) at src:40:1-73:
- text: "anchor-abs-2" - text: "anchor-abs-2"
- link: /dir1/dir2/../../dir1/./dir2/d2f2.md - link: /dir1/dir2/../../dir1/./dir2/d2f2.md
- anchor: existing-anchor-d2f2 - anchor: existing-anchor-d2f2
File does not exist: File does not exist:
dir1/dir1/dir2/../../dir1/./dir2/d2f2.md dir1/dir2/d2f2.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (relative) at src:51:1-42: bad reference (relative) at src:51:1-42:
- text: "path-through-top-dir" - text: "path-through-top-dir"
- link: ../../dir1/d1f1.md - link: ../../dir1/d1f1.md
- anchor: - - anchor: -
Link targets a local file outside repository: Link targets a local file outside repository:
dir1/dir2/../../dir1/d1f1.md dir2/../../dir1/d1f1.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (relative) at src:52:1-75: bad reference (relative) at src:52:1-75:
- text: "path-through-top-dir-with-anchor" - text: "path-through-top-dir-with-anchor"
- link: ../../dir1/d1f1.md - link: ../../dir1/d1f1.md
- anchor: existing-anchor-d1f1 - anchor: existing-anchor-d1f1
Link targets a local file outside repository: Link targets a local file outside repository:
dir1/dir2/../../dir1/d1f1.md dir2/../../dir1/d1f1.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (relative) at src:53:1-26: bad reference (relative) at src:53:1-26:
- text: "ref-to-d0" - text: "ref-to-d0"
- link: ../../d0f1.md - link: ../../d0f1.md
- anchor: - - anchor: -
Link targets a local file outside repository: Link targets a local file outside repository:
dir1/dir2/../../d0f1.md dir2/../../d0f1.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (absolute) at src:57:1-16: bad reference (absolute) at src:57:1-16:
- text: "A" - text: "A"
- link: /../../a.md - link: /../../a.md
- anchor: - - anchor: -
Link targets a local file outside repository: Link targets a local file outside repository:
dir1/../../a.md ../../a.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (absolute) at src:58:1-18: bad reference (absolute) at src:58:1-18:
- text: "B" - text: "B"
- link: /b/../../b.md - link: /b/../../b.md
- anchor: - - anchor: -
Link targets a local file outside repository: Link targets a local file outside repository:
dir1/b/../../b.md b/../../b.md
Invalid references dumped, 16 in total. Invalid references dumped, 16 in total.

44
tests/golden/check-local-refs/expected3.gold
View File

@ -1,6 +1,6 @@
=== Invalid references found === === Invalid references found ===
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (file-local) at src:9:1-18: bad reference (file-local) at src:9:1-18:
- text: "bad-cf-ref" - text: "bad-cf-ref"
- link: - - link: -
@ -8,25 +8,25 @@
Anchor 'bad' is not present Anchor 'bad' is not present
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (relative) at src:27:1-43: bad reference (relative) at src:27:1-43:
- text: "bad-file-rel" - text: "bad-file-rel"
- link: ../a/b/c/unexisting-file.md - link: ../a/b/c/unexisting-file.md
- anchor: - - anchor: -
File does not exist: File does not exist:
dir1/dir2/../a/b/c/unexisting-file.md a/b/c/unexisting-file.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (relative) at src:28:1-31: bad reference (relative) at src:28:1-31:
- text: "bad-casing-file-rel" - text: "bad-casing-file-rel"
- link: D2F2.md/ - link: D2F2.md/
- anchor: - - anchor: -
File does not exist: File does not exist:
dir1/dir2/D2F2.md/ dir2/D2F2.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (relative) at src:31:1-38: bad reference (relative) at src:31:1-38:
- text: "bad-anchor-rel-1" - text: "bad-anchor-rel-1"
- link: d2f2.md - link: d2f2.md
@ -34,76 +34,76 @@
Anchor 'bad-anchor' is not present Anchor 'bad-anchor' is not present
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (relative) at src:32:1-49: bad reference (relative) at src:32:1-49:
- text: "bad-anchor-rel-2" - text: "bad-anchor-rel-2"
- link: unexisting-file.md - link: unexisting-file.md
- anchor: bad-anchor - anchor: bad-anchor
File does not exist: File does not exist:
dir1/dir2/unexisting-file.md dir2/unexisting-file.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (absolute) at src:36:1-29: bad reference (absolute) at src:36:1-29:
- text: "file-abs-1" - text: "file-abs-1"
- link: /dir1/./d1f1.md - link: /dir1/./d1f1.md
- anchor: - - anchor: -
File does not exist: File does not exist:
dir1/dir1/./d1f1.md dir1/d1f1.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (absolute) at src:37:1-21: bad reference (absolute) at src:37:1-21:
- text: "folder-abs-1" - text: "folder-abs-1"
- link: /dir1 - link: /dir1
- anchor: - - anchor: -
File does not exist: File does not exist:
dir1/dir1 dir1
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (absolute) at src:38:1-30: bad reference (absolute) at src:38:1-30:
- text: "folder-abs-2" - text: "folder-abs-2"
- link: /dir1/dir2/../ - link: /dir1/dir2/../
- anchor: - - anchor: -
File does not exist: File does not exist:
dir1/dir1/dir2/../ dir1
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (absolute) at src:39:1-58: bad reference (absolute) at src:39:1-58:
- text: "anchor-abs-1" - text: "anchor-abs-1"
- link: /dir1/../dir1/d1f1.md - link: /dir1/../dir1/d1f1.md
- anchor: existing-anchor-d1f1 - anchor: existing-anchor-d1f1
File does not exist: File does not exist:
dir1/dir1/../dir1/d1f1.md dir1/d1f1.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (absolute) at src:40:1-73: bad reference (absolute) at src:40:1-73:
- text: "anchor-abs-2" - text: "anchor-abs-2"
- link: /dir1/dir2/../../dir1/./dir2/d2f2.md - link: /dir1/dir2/../../dir1/./dir2/d2f2.md
- anchor: existing-anchor-d2f2 - anchor: existing-anchor-d2f2
File does not exist: File does not exist:
dir1/dir1/dir2/../../dir1/./dir2/d2f2.md dir1/dir2/d2f2.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (relative) at src:51:1-42: bad reference (relative) at src:51:1-42:
- text: "path-through-top-dir" - text: "path-through-top-dir"
- link: ../../dir1/d1f1.md - link: ../../dir1/d1f1.md
- anchor: - - anchor: -
Link targets a local file outside repository: Link targets a local file outside repository:
dir1/dir2/../../dir1/d1f1.md dir2/../../dir1/d1f1.md
➥ In file dir1/dir2/d2f1.md ➥ In file dir2/d2f1.md
bad reference (relative) at src:52:1-75: bad reference (relative) at src:52:1-75:
- text: "path-through-top-dir-with-anchor" - text: "path-through-top-dir-with-anchor"
- link: ../../dir1/d1f1.md - link: ../../dir1/d1f1.md
- anchor: existing-anchor-d1f1 - anchor: existing-anchor-d1f1
Link targets a local file outside repository: Link targets a local file outside repository:
dir1/dir2/../../dir1/d1f1.md dir2/../../dir1/d1f1.md
Invalid references dumped, 12 in total. Invalid references dumped, 12 in total.

4
tests/golden/check-scan-errors/expected.gold
View File

@ -46,7 +46,7 @@ Scan errors dumped, 7 in total.
- anchor: - - anchor: -
File does not exist: File does not exist:
./no-file.md no-file.md
➥ In file check-scan-errors.md ➥ In file check-scan-errors.md
bad reference (relative) at src:23:1-24: bad reference (relative) at src:23:1-24:
@ -64,6 +64,6 @@ Scan errors dumped, 7 in total.
- anchor: - - anchor: -
File does not exist: File does not exist:
./a.md a.md
Invalid references dumped, 3 in total. Invalid references dumped, 3 in total.