diff --git a/src/Xrefcheck/Command.hs b/src/Xrefcheck/Command.hs index 16620a86..36ee24a0 100644 --- a/src/Xrefcheck/Command.hs +++ b/src/Xrefcheck/Command.hs @@ -25,7 +25,7 @@ import Xrefcheck.Progress (allowRewrite) import Xrefcheck.Scan (FormatsSupport, ScanError (..), ScanResult (..), reportScanErrs, scanRepo, specificFormatsSupport) -import Xrefcheck.Scanners.Markdown (markdownSupport) +import Xrefcheck.Scanners.Markdown (MarkdownConfig (mcFlavor), markdownSupport) import Xrefcheck.System (askWithinCI) import Xrefcheck.Util import Xrefcheck.Verify (reportVerifyErrs, verifyErrors, verifyRepo) @@ -70,7 +70,9 @@ defaultAction Options{..} = do (ScanResult scanErrs repoInfo) <- allowRewrite showProgressBar $ \rw -> do let fullConfig = addExclusionOptions (cExclusions config) oExclusionOptions - scanRepo oScanPolicy rw (formats $ cScanners config) fullConfig oRoot + formatsSupport = formats $ cScanners config + flavor = mcFlavor $ scMarkdown $ cScanners config + scanRepo oScanPolicy rw formatsSupport fullConfig flavor oRoot when oVerbose $ fmt [int|| diff --git a/src/Xrefcheck/Core.hs b/src/Xrefcheck/Core.hs index 5a9d58c6..b6e19716 100644 --- a/src/Xrefcheck/Core.hs +++ b/src/Xrefcheck/Core.hs @@ -21,7 +21,7 @@ import Data.DList qualified as DList import Data.List qualified as L import Data.Reflection (Given) import Data.Text qualified as T -import Fmt (Buildable (..), Builder) +import Fmt (Buildable (..)) import System.FilePath.Posix (isPathSeparator) import Text.Interpolation.Nyan import Time (Second, Time) @@ -146,14 +146,6 @@ data DirectoryStatus | UntrackedDirectory deriving stock (Show) --- | All tracked files and directories. -data RepoInfo = RepoInfo - { riFiles :: Map FilePath FileStatus - -- ^ Files from the repo with `FileInfo` attached to files that we've scanned. - , riDirectories :: Map FilePath DirectoryStatus - -- ^ Directories containing those files. - } deriving stock (Show) - ----------------------------------------------------------- -- Instances ----------------------------------------------------------- @@ -203,19 +195,6 @@ instance Given ColorMode => Buildable FileInfo where #{ interpolateIndentF 4 $ maybe "none" interpolateBlockListF (nonEmpty _fiAnchors) } |] -instance Given ColorMode => Buildable RepoInfo where - build (RepoInfo m _) - | Just scanned <- nonEmpty [(name, info) | (name, Scanned info) <- toPairs m] - = interpolateUnlinesF $ buildFileReport <$> scanned - where - buildFileReport :: ([Char], FileInfo) -> Builder - buildFileReport (name, info) = - [int|| - #{ colorIfNeeded Cyan $ name }: - #{ interpolateIndentF 2 $ build info } - |] - build _ = "No scannable files found." - ----------------------------------------------------------- -- Analysing ----------------------------------------------------------- diff --git a/src/Xrefcheck/RepoInfo.hs b/src/Xrefcheck/RepoInfo.hs new file mode 100644 index 00000000..c3399322 --- /dev/null +++ b/src/Xrefcheck/RepoInfo.hs @@ -0,0 +1,113 @@ +{- SPDX-FileCopyrightText: 2022 Serokell + - + - SPDX-License-Identifier: MPL-2.0 + -} + +{-# LANGUAGE GADTs #-} + +module Xrefcheck.RepoInfo + ( RepoInfo + , mkRepoInfo + , riFiles + , lookupFile + , lookupDirectory + ) where + +import Universum + +import Data.Char qualified as C +import Data.Map qualified as M +import Data.Reflection (Given) +import Fmt (Buildable (build), Builder) +import Text.Interpolation.Nyan + +import Xrefcheck.Core +import Xrefcheck.Util + +-- | Supose that we already have a type, `CanonicalPath` +-- that corresponds to a canonicalized `FilePath` (#197). +-- This is an example with an alias, and that is why +-- Golden tests are failing. +type CanonicalPath = FilePath + +-- | The repository info: files and directories. +data RepoInfo = forall a. RepoInfo (RepoInfo' a) + +-- | Generate a 'RepoInfo' with efficient path lookup depending +-- on the case-sensitivity of a given Markdown flavor. +mkRepoInfo + :: Flavor + -> [(CanonicalPath, FileStatus)] + -> [(CanonicalPath, DirectoryStatus)] -> RepoInfo +mkRepoInfo flavor files directories = + if caseInsensitiveAnchors flavor + then RepoInfo $ RICaseInsensitive $ RepoInfoData + { ridFiles = M.fromList $ fmap (first CaseInsensitivePath) $ files + , ridDirectories = M.fromList $ fmap (first CaseInsensitivePath) $ directories + } + else RepoInfo $ RICaseSensitive $ RepoInfoData + { ridFiles = M.fromList $ fmap (first CaseSensitivePath) $ files + , ridDirectories = M.fromList $ fmap (first CaseSensitivePath) $ directories + } + +-- | All tracked files and directories. +data RepoInfoData a = RepoInfoData + { ridFiles :: Map a FileStatus + -- ^ Files from the repo with `FileInfo` attached to files that we've scanned. + , ridDirectories :: Map a DirectoryStatus + -- ^ Directories containing those files. + } + +data RepoInfo' a where + RICaseInsensitive :: RepoInfoData CaseInsensitivePath -> RepoInfo' CaseInsensitivePath + RICaseSensitive :: RepoInfoData CaseSensitivePath -> RepoInfo' CaseSensitivePath + +-- Files from the repo with `FileInfo` attached to files that we've scanned. +riFiles :: RepoInfo -> [(CanonicalPath, FileStatus)] +riFiles (RepoInfo (RICaseInsensitive (RepoInfoData{..}))) = + first unCaseInsensitivePath <$> toPairs ridFiles +riFiles (RepoInfo (RICaseSensitive (RepoInfoData{..}))) = + first unCaseSensitivePath <$> toPairs ridFiles + +-- Search for a file in the repository. +lookupFile :: CanonicalPath -> RepoInfo -> Maybe FileStatus +lookupFile path (RepoInfo (RICaseInsensitive (RepoInfoData{..}))) = + M.lookup (CaseInsensitivePath path) ridFiles +lookupFile path (RepoInfo (RICaseSensitive (RepoInfoData{..}))) = + M.lookup (CaseSensitivePath path) ridFiles + +-- Search for a directory in the repository. +lookupDirectory :: CanonicalPath -> RepoInfo -> Maybe DirectoryStatus +lookupDirectory path (RepoInfo (RICaseInsensitive (RepoInfoData{..}))) = + M.lookup (CaseInsensitivePath path) ridDirectories +lookupDirectory path (RepoInfo (RICaseSensitive (RepoInfoData{..}))) = + M.lookup (CaseSensitivePath path) ridDirectories + +data CaseSensitivePath = CaseSensitivePath + { unCaseSensitivePath :: CanonicalPath + } deriving stock (Show, Eq, Ord) + +data CaseInsensitivePath = CaseInsensitivePath + { unCaseInsensitivePath :: CanonicalPath + } deriving stock (Show) + +instance Eq CaseInsensitivePath where + (CaseInsensitivePath p1) == (CaseInsensitivePath p2) = + on (==) (fmap C.toLower) p1 p2 + +instance Ord CaseInsensitivePath where + compare (CaseInsensitivePath p1) (CaseInsensitivePath p2) = + on compare (fmap C.toLower) p1 p2 + +instance Given ColorMode => Buildable RepoInfo where + build repoInfo + | Just scanned <- nonEmpty [(name, info) | (name, Scanned info) <- riFiles repoInfo] + = interpolateUnlinesF $ buildFileReport <$> scanned + where + buildFileReport :: (CanonicalPath, FileInfo) -> Builder + buildFileReport (name, info) = + [int|| + #{ colorIfNeeded Cyan $ name }: + #{ interpolateIndentF 2 $ build info } + |] + build _ = "No scannable files found." diff --git a/src/Xrefcheck/Scan.hs b/src/Xrefcheck/Scan.hs index da312a0e..36dbfc1f 100644 --- a/src/Xrefcheck/Scan.hs +++ b/src/Xrefcheck/Scan.hs @@ -13,7 +13,6 @@ module Xrefcheck.Scan , Extension , ScanAction , FormatsSupport - , RepoInfo (..) , ReadDirectoryMode(..) , ScanError (..) , ScanErrorDescription (..) @@ -47,6 +46,7 @@ import Text.Regex.TDFA.Text qualified as R import Xrefcheck.Core import Xrefcheck.Progress +import Xrefcheck.RepoInfo import Xrefcheck.System (RelGlobPattern, matchesGlobPatterns, normaliseGlobPattern, readingSystem) import Xrefcheck.Util @@ -87,7 +87,7 @@ type FormatsSupport = Extension -> Maybe ScanAction data ScanResult = ScanResult { srScanErrors :: [ScanError] , srRepoInfo :: RepoInfo - } deriving stock (Show) + } data ScanError = ScanError { sePosition :: Position @@ -189,8 +189,8 @@ readDirectoryWith mode config scanner root = scanRepo :: MonadIO m - => ScanPolicy -> Rewrite -> FormatsSupport -> ExclusionConfig -> FilePath -> m ScanResult -scanRepo scanMode rw formatsSupport config root = do + => ScanPolicy -> Rewrite -> FormatsSupport -> ExclusionConfig -> Flavor -> FilePath -> m ScanResult +scanRepo scanMode rw formatsSupport config flavor root = do putTextRewrite rw "Scanning repository..." when (not $ isDirectory root) $ @@ -221,12 +221,10 @@ scanRepo scanMode rw formatsSupport config root = do let trackedDirs = foldMap (getDirs . fst) processedFiles untrackedDirs = foldMap (getDirs . fst) notProcessedFiles - return . ScanResult errs $ RepoInfo - { riFiles = M.fromList $ processedFiles <> notProcessedFiles - , riDirectories = M.fromList - $ map (, TrackedDirectory) trackedDirs - <> map (, UntrackedDirectory) untrackedDirs - } + return . ScanResult errs $ mkRepoInfo + flavor + (processedFiles <> notProcessedFiles) + (map (, TrackedDirectory) trackedDirs <> map (, UntrackedDirectory) untrackedDirs) where mscanner :: FilePath -> Maybe ScanAction mscanner = formatsSupport . takeExtension diff --git a/src/Xrefcheck/Verify.hs b/src/Xrefcheck/Verify.hs index 1ed1fdbb..e783113f 100644 --- a/src/Xrefcheck/Verify.hs +++ b/src/Xrefcheck/Verify.hs @@ -57,8 +57,7 @@ import Network.HTTP.Req defaultHttpConfig, ignoreResponse, req, runReq, useURI) import Network.HTTP.Types.Header (hRetryAfter) import Network.HTTP.Types.Status (Status, statusCode, statusMessage) -import System.FilePath.Posix - (equalFilePath, joinPath, makeRelative, normalise, splitDirectories, takeDirectory, ()) +import System.FilePath.Posix (makeRelative, normalise, splitDirectories, takeDirectory, ()) import Text.Interpolation.Nyan import Text.ParserCombinators.ReadPrec qualified as ReadPrec (lift) import Text.Regex.TDFA.Text (Regex, regexec) @@ -74,6 +73,7 @@ import Xrefcheck.Config import Xrefcheck.Core import Xrefcheck.Orphans () import Xrefcheck.Progress +import Xrefcheck.RepoInfo import Xrefcheck.Scan import Xrefcheck.Scanners.Markdown (MarkdownConfig (mcFlavor)) import Xrefcheck.System @@ -361,10 +361,10 @@ verifyRepo config@Config{..} mode root - repoInfo'@(RepoInfo files _) + repoInfo = do let toScan = do - (file, fileInfo) <- M.toList files + (file, fileInfo) <- riFiles repoInfo guard . not $ matchesGlobPatterns root (ecIgnoreRefsFrom cExclusions) file case fileInfo of Scanned fi -> do @@ -379,7 +379,7 @@ verifyRepo accumulated <- loopAsyncUntil (printer progressRef) do forConcurrentlyCaching toScan ifExternalThenCache $ \(file, ref) -> - verifyReference config mode progressRef repoInfo' root file ref + verifyReference config mode progressRef repoInfo root file ref case accumulated of Right res -> return $ fold res Left (exception, partialRes) -> do @@ -431,7 +431,7 @@ verifyReference config@Config{..} mode progressRef - (RepoInfo files dirs) + repoInfo root fileWithReference ref@Reference{..} @@ -545,22 +545,6 @@ verifyReference Left TrackedDirectory -> pass -- path leads to directory, currently -- if such link contain anchor, we ignore it - -- expands ".." and "." - -- expandIndirections "a/b/../c" = "a/c" - -- expandIndirections "a/b/c/../../d" = "a/d" - -- expandIndirections "../../a" = "../../a" - -- expandIndirections "a/./b" = "a/b" - -- expandIndirections "a/b/./../c" = "a/c" - expandIndirections :: FilePath -> FilePath - expandIndirections = joinPath . reverse . expand 0 . reverse . splitDirectories - where - expand :: Int -> [FilePath] -> [FilePath] - expand acc ("..":xs) = expand (acc+1) xs - expand acc (".":xs) = expand acc xs - expand 0 (x:xs) = x : expand 0 xs - expand acc (_:xs) = expand (acc-1) xs - expand acc [] = replicate acc ".." - checkReferredFileIsInsideRepo file = unless (noNegativeNesting $ makeRelative root file) $ throwError (LocalFileOutsideRepo file) @@ -580,18 +564,9 @@ verifyReference -- Returns `Nothing` when path corresponds to an existing (and tracked) directory tryGetFileStatus :: FilePath -> ExceptT VerifyError IO (Either DirectoryStatus FileStatus) tryGetFileStatus file - | Just f <- mFile = return $ Right f - | Just d <- mDir = return $ Left d + | Just f <- lookupFile file repoInfo = return $ Right f + | Just d <- lookupDirectory file repoInfo = return $ Left d | otherwise = throwError (LocalFileDoesNotExist file) - where - matchesFilePath :: FilePath -> Bool - matchesFilePath = equalFilePath $ expandIndirections file - - mFile :: Maybe FileStatus - mFile = (files M.!) <$> find matchesFilePath (M.keys files) - - mDir :: Maybe DirectoryStatus - mDir = (dirs M.!) <$> find matchesFilePath (M.keys dirs) checkAnchor file fileAnchors anchor = do checkAnchorReferenceAmbiguity file fileAnchors anchor diff --git a/tests/Test/Xrefcheck/IgnoreRegexSpec.hs b/tests/Test/Xrefcheck/IgnoreRegexSpec.hs index c3143086..acf3fe17 100644 --- a/tests/Test/Xrefcheck/IgnoreRegexSpec.hs +++ b/tests/Test/Xrefcheck/IgnoreRegexSpec.hs @@ -39,7 +39,7 @@ test_ignoreRegex = give WithoutColors $ in testGroup "Regular expressions performance" [ testCase "Check that only not matched links are verified" $ do scanResult <- allowRewrite showProgressBar $ \rw -> - scanRepo OnlyTracked rw formats (config ^. cExclusionsL) root + scanRepo OnlyTracked rw formats (config ^. cExclusionsL) GitHub root verifyRes <- allowRewrite showProgressBar $ \rw -> verifyRepo rw config verifyMode root $ srRepoInfo scanResult diff --git a/tests/Test/Xrefcheck/TrailingSlashSpec.hs b/tests/Test/Xrefcheck/TrailingSlashSpec.hs index 8f0f0a1a..9cb0f27a 100644 --- a/tests/Test/Xrefcheck/TrailingSlashSpec.hs +++ b/tests/Test/Xrefcheck/TrailingSlashSpec.hs @@ -15,6 +15,7 @@ import Text.Interpolation.Nyan import Xrefcheck.Config import Xrefcheck.Core import Xrefcheck.Progress +import Xrefcheck.RepoInfo import Xrefcheck.Scan import Xrefcheck.Scanners.Markdown import Xrefcheck.Util @@ -27,9 +28,9 @@ test_slash = testGroup "Trailing forward slash detection" $ testCase ("All the files within the root \"" <> root <> "\" should exist") $ do - (ScanResult _ (RepoInfo repoInfo _)) <- allowRewrite False $ \rw -> - scanRepo OnlyTracked rw format (cExclusions config & ecIgnoreL .~ []) root - nonExistentFiles <- lefts <$> forM (keys repoInfo) (\filePath -> do + (ScanResult _ repoInfo) <- allowRewrite False $ \rw -> + scanRepo OnlyTracked rw format (cExclusions config & ecIgnoreL .~ []) GitHub root + nonExistentFiles <- lefts <$> forM (fst <$> riFiles repoInfo) (\filePath -> do predicate <- doesFileExist filePath return $ if predicate then Right () diff --git a/tests/Test/Xrefcheck/UtilRequests.hs b/tests/Test/Xrefcheck/UtilRequests.hs index 8582cd8c..e17ead92 100644 --- a/tests/Test/Xrefcheck/UtilRequests.hs +++ b/tests/Test/Xrefcheck/UtilRequests.hs @@ -12,7 +12,6 @@ module Test.Xrefcheck.UtilRequests import Universum import Control.Exception qualified as E -import Data.Map qualified as M import Text.Interpolation.Nyan import Control.Concurrent (forkIO, killThread) @@ -20,6 +19,7 @@ import Test.Tasty.HUnit (assertBool) import Xrefcheck.Config import Xrefcheck.Core import Xrefcheck.Progress +import Xrefcheck.RepoInfo import Xrefcheck.Scan import Xrefcheck.Util import Xrefcheck.Verify @@ -72,4 +72,4 @@ verifyReferenceWithProgress :: Reference -> IORef VerifyProgress -> IO (VerifyRe verifyReferenceWithProgress reference progRef = do fmap wrlItem <$> verifyReference (defConfig GitHub & cExclusionsL . ecIgnoreExternalRefsToL .~ []) FullMode - progRef (RepoInfo M.empty mempty) "." "" reference + progRef (mkRepoInfo GitHub mempty mempty) "." "" reference