Merge pull request #24 from serokell/martoon/#1-not-scanned-cli

Add `ignored` CLI option

CHANGES.md

@@ -7,6 +7,14 @@
 Unreleased
 ==========
 
+0.1.1
+=======
+
+* [#19](https://github.com/serokell/xrefcheck/pull/24)
+  + Make `ignored` in config consider only exact matches.
+  + Improve virtual files consideration.
+  + Add `ignored` CLI option.
+
 0.1.0.0
 =======
 

exec/Main.hs

@@ -39,19 +39,20 @@ defaultAction Options{..} = do
       Just configPath -> do
         readConfig configPath
 
-    repoInfo <- allowRewrite oShowProgressBar $ \rw ->
-        gatherRepoInfo rw formats (cTraversal config) root
+    repoInfo <- allowRewrite oShowProgressBar $ \rw -> do
+        let fullConfig = addTraversalOptions (cTraversal config) oTraversalOptions
+        gatherRepoInfo rw formats fullConfig root
 
     when oVerbose $
-        fmtLn $ "Repository data:\n\n" <> indentF 2 (build repoInfo)
+        fmtLn $ "=== Repository data ===\n\n" <> indentF 2 (build repoInfo)
 
     verifyRes <- allowRewrite oShowProgressBar $ \rw ->
         verifyRepo rw (cVerification config) oMode root repoInfo
     case verifyErrors verifyRes of
         Nothing ->
             fmtLn "All repository links are valid."
         Just (toList -> errs) -> do
-            fmt $ "Invalid references found:\n\n" <>
+            fmt $ "=== Invalid references found ===\n\n" <>
                   indentF 2 (blockListF' "➥ " build errs)
             fmtLn $ "Invalid references dumped, " <> build (length errs) <> " in total."
             exitFailure

package.yaml

@@ -3,7 +3,7 @@
 # SPDX-License-Identifier: MPL-2.0
 
 name:                xrefcheck
-version:             0.1.0.0
+version:             0.1.1
 github:              serokell/xrefcheck
 license:             MPL-2.0
 license-file:        LICENSE

src-files/def-config.yaml

@@ -4,7 +4,7 @@
 
 # Parameters of repository traversal.
 traversal:
-  # Folders which we pretend do not exist
+  # Files and folders which we pretend do not exist
   # (so they are neither analyzed nor can be referenced).
   ignored:
     # Git files
@@ -23,7 +23,7 @@ verification:
   # declaring "Response timeout".
   externalRefCheckTimeout: 10s
 
-  # File prefixes, references in which should not be analyzed.
+  # Prefixes of files, references in which should not be analyzed.
   notScanned:
     # GitHub-specific files
     - .github/pull_request_template.md

src/Xrefcheck/CLI.hs

@@ -11,6 +11,8 @@ module Xrefcheck.CLI
     , shouldCheckExternal
     , Command (..)
     , Options (..)
+    , TraversalOptions (..)
+    , addTraversalOptions
     , defaultConfigPaths
     , getCommand
     ) where
@@ -21,6 +23,7 @@ import Options.Applicative (Parser, ReadM, command, eitherReader, execParser, fu
                             short, strOption, switch, value)
 import Paths_xrefcheck (version)
 
+import Xrefcheck.Config
 import Xrefcheck.Core
 
 modeReadM :: ReadM VerifyMode
@@ -43,13 +46,25 @@ data Command
   | DumpConfig FilePath
 
 data Options = Options
-    { oConfigPath      :: Maybe FilePath
-    , oRoot            :: FilePath
-    , oMode            :: VerifyMode
-    , oVerbose         :: Bool
-    , oShowProgressBar :: Bool
+    { oConfigPath       :: Maybe FilePath
+    , oRoot             :: FilePath
+    , oMode             :: VerifyMode
+    , oVerbose          :: Bool
+    , oShowProgressBar  :: Bool
+    , oTraversalOptions :: TraversalOptions
     }
 
+data TraversalOptions = TraversalOptions
+    { toIgnored :: [FilePath]
+    }
+
+addTraversalOptions :: TraversalConfig -> TraversalOptions -> TraversalConfig
+addTraversalOptions TraversalConfig{..} (TraversalOptions ignored) =
+  TraversalConfig
+  { tcIgnored = tcIgnored ++ ignored
+  , ..
+  }
+
 -- | Where to try to seek configuration if specific path is not set.
 defaultConfigPaths :: [FilePath]
 defaultConfigPaths = ["./xrefcheck.yaml", "./.xrefcheck.yaml"]
@@ -87,8 +102,17 @@ optionsParser = do
     oShowProgressBar <- fmap not . switch $
         long "no-progress" <>
         help "Do not display progress bar during verification."
+    oTraversalOptions <- traversalOptionsParser
     return Options{..}
 
+traversalOptionsParser :: Parser TraversalOptions
+traversalOptionsParser = do
+    toIgnored <- many . strOption $
+        long "ignored" <>
+        metavar "FILEPATH" <>
+        help "Files and folders which we pretend do not exist."
+    return TraversalOptions{..}
+
 dumpConfigOptions :: Parser FilePath
 dumpConfigOptions = hsubparser $
   command "dump-config" $

src/Xrefcheck/Config.hs

@@ -12,11 +12,11 @@ import Data.Aeson.TH (deriveFromJSON)
 import Data.Yaml (FromJSON (..), decodeEither', prettyPrintParseException, withText)
 import Instances.TH.Lift ()
 import qualified Language.Haskell.TH.Syntax as TH
-import System.FilePath.Posix ((</>))
+import System.FilePath ((</>))
 import TH.RelativePaths (qReadFileBS)
 import Time (KnownRatName, Second, Time, unitsP)
 
-import Xrefcheck.System (CanonicalizedGlobPattern)
+import Xrefcheck.System (RelGlobPattern)
 
 -- | Overall config.
 data Config = Config
@@ -27,17 +27,17 @@ data Config = Config
 -- | Config of repositry traversal.
 data TraversalConfig = TraversalConfig
     { tcIgnored   :: [FilePath]
-      -- ^ Folders, files in which we completely ignore.
+      -- ^ Files and folders, files in which we completely ignore.
     }
 
 -- | Config of verification.
 data VerifyConfig = VerifyConfig
     { vcAnchorSimilarityThreshold :: Double
     , vcExternalRefCheckTimeout   :: Time Second
-    , vcVirtualFiles              :: [CanonicalizedGlobPattern]
+    , vcVirtualFiles              :: [RelGlobPattern]
       -- ^ Files which we pretend do exist.
     , vcNotScanned                :: [FilePath]
-      -- ^ Folders, references in files of which we should not analyze.
+      -- ^ Prefixes of files, references in which we should not analyze.
     }
 
 -----------------------------------------------------------

src/Xrefcheck/Core.hs

@@ -19,7 +19,7 @@ import qualified Data.Map as M
 import qualified Data.Text as T
 import Fmt (Buildable (..), blockListF, blockListF', nameF, (+|), (|+))
 import System.Console.Pretty (Color (..), Style (..), color, style)
-import System.FilePath.Posix (isPathSeparator, pathSeparator)
+import System.FilePath (isPathSeparator, pathSeparator)
 import Text.Numeral.Roman (toRoman)
 
 import Xrefcheck.Progress

src/Xrefcheck/Scan.hs

@@ -19,7 +19,7 @@ import qualified Data.Foldable as F
 import qualified Data.Map as M
 import GHC.Err (errorWithoutStackTrace)
 import qualified System.Directory.Tree as Tree
-import System.FilePath.Posix (takeDirectory, takeExtension, (</>))
+import System.FilePath (takeDirectory, takeExtension, (</>))
 
 import Xrefcheck.Config
 import Xrefcheck.Core
@@ -66,7 +66,7 @@ gatherRepoInfo rw formatsSupport config root = do
     dropSndMaybes l = [(a, b) | (a, Just b) <- l]
 
     ignored = map (root </>) (tcIgnored config)
-    isIgnored path = any (`isPrefixOf` path) ignored
+    isIgnored path = path `elem` ignored
     filterExcludedDirs cur = \case
         Tree.Dir name subfiles ->
             let subfiles' =

src/Xrefcheck/System.hs

@@ -5,25 +5,43 @@
 
 module Xrefcheck.System
     ( readingSystem
-    , CanonicalizedGlobPattern (..)
+    , RelGlobPattern (..)
+    , bindGlobPattern
     ) where
 
 import Data.Aeson (FromJSON (..), withText)
 import GHC.IO.Unsafe (unsafePerformIO)
 import System.Directory (canonicalizePath)
+import System.FilePath ((</>))
 import qualified System.FilePath.Glob as Glob
 
 -- | We can quite safely treat surrounding filesystem as frozen,
 -- so IO reading operations can be turned into pure values.
 readingSystem :: IO a -> a
 readingSystem = unsafePerformIO
 
--- | Glob pattern with 'canonicalizePath' applied O_o.
-newtype CanonicalizedGlobPattern = CanonicalizedGlobPattern Glob.Pattern
+-- | Glob pattern relative to repository root.
+newtype RelGlobPattern = RelGlobPattern FilePath
 
-instance FromJSON CanonicalizedGlobPattern where
-    parseJSON = withText "Repo-rooted glob pattern" $ \path -> do
-        let !cpath = readingSystem $ canonicalizePath (toString path)
-        cpat <- Glob.tryCompileWith Glob.compDefault cpath
-                & either fail pure
-        return $ CanonicalizedGlobPattern cpat
+bindGlobPattern :: FilePath -> RelGlobPattern -> Glob.Pattern
+bindGlobPattern root (RelGlobPattern relPat) = readingSystem $ do
+  -- TODO [#26] try to avoid using canonicalization
+  absPat <- canonicalizePath (root </> relPat)
+  case Glob.tryCompileWith globCompileOptions absPat of
+    Left err ->
+      error $ "Glob pattern compilation failed after canonicalization: " <>
+              toText err
+    Right pat ->
+      return pat
+
+instance FromJSON RelGlobPattern where
+    parseJSON = withText "Repo-relative glob pattern" $ \path -> do
+        let spath = toString path
+        -- Checking path is sane
+        _ <- Glob.tryCompileWith globCompileOptions spath
+             & either fail pure
+        return (RelGlobPattern spath)
+
+-- | Glob compilation options we use.
+globCompileOptions :: Glob.CompOptions
+globCompileOptions = Glob.compDefault

src/Xrefcheck/Verify.hs

@@ -35,8 +35,8 @@ import Network.HTTP.Req (GET (..), HEAD (..), HttpException (..), NoReqBody (..)
 import Network.HTTP.Types.Status (Status, statusCode, statusMessage)
 import System.Console.Pretty (Style (..), style)
 import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist)
+import System.FilePath (takeDirectory, (</>))
 import qualified System.FilePath.Glob as Glob
-import System.FilePath.Posix (takeDirectory, (</>))
 import Time (RatioNat, Second, Time (..), ms, threadDelay, timeout)
 
 import Xrefcheck.Config
@@ -207,7 +207,8 @@ verifyReference config@VerifyConfig{..} mode progressRef (RepoInfo repoInfo)
         let cfile = readingSystem $ canonicalizePath file
         let isVirtual = or
                 [ Glob.match pat cfile
-                | CanonicalizedGlobPattern pat <- vcVirtualFiles ]
+                | virtualFile <- vcVirtualFiles
+                , let pat = bindGlobPattern root virtualFile ]
 
         unless (fileExists || dirExists || isVirtual) $
             throwError (FileDoesNotExist file)