[#244] Symlink scanner

Problem: As GitHub and GitLab do not render symlinks as the file they
point to, we are considering to implement a new scanner for symlinks
that verifies them up to some extent.

Solution: A scanner that validates the reference from a symlink has been
implemented in the same style as the markdown scanner.

src/Xrefcheck/Command.hs

@@ -22,9 +22,8 @@ import Xrefcheck.Config
 import Xrefcheck.Core (Flavor (..))
 import Xrefcheck.Progress (allowRewrite)
 import Xrefcheck.Scan
-  (FormatsSupport, ScanError (..), ScanResult (..), reportScanErrs, scanRepo,
-  specificFormatsSupport)
 import Xrefcheck.Scanners.Markdown (markdownSupport)
+import Xrefcheck.Scanners.Symlink (symlinkSupport)
 import Xrefcheck.System (askWithinCI)
 import Xrefcheck.Util
 import Xrefcheck.Verify (reportVerifyErrs, verifyErrors, verifyRepo)
@@ -34,9 +33,10 @@ readConfig path = fmap overrideConfig do
   decodeFileEither path
     >>= either (error . toText . prettyPrintParseException) pure
 
-formats :: ScannersConfig -> FormatsSupport
-formats ScannersConfig{..} = specificFormatsSupport
+configuredFileSupport :: ScannersConfig -> FileSupport
+configuredFileSupport ScannersConfig{..} = firstFileSupport
     [ markdownSupport scMarkdown
+    , symlinkSupport
     ]
 
 findFirstExistingFile :: [FilePath] -> IO (Maybe FilePath)
@@ -74,8 +74,8 @@ defaultAction Options{..} = do
 
     (ScanResult scanErrs repoInfo) <- allowRewrite showProgressBar $ \rw -> do
       let fullConfig = addExclusionOptions (cExclusions config) oExclusionOptions
-          formatsSupport = formats $ cScanners config
-      scanRepo oScanPolicy rw formatsSupport fullConfig oRoot
+          fileSupport = configuredFileSupport $ cScanners config
+      scanRepo oScanPolicy rw fileSupport fullConfig oRoot
 
     when oVerbose $
       fmt [int||

src/Xrefcheck/Core.hs

@@ -235,36 +235,41 @@ instance Given ColorMode => Buildable Reference where
         case rifLink of
           FLLocal ->
             [int||
-            reference #{paren $ colorIfNeeded Green "file-local"} #{rPos}:
+            reference #{paren $ colorIfNeeded Green "file-local"}#{posSep}#{rPos}:
               - text: #s{rName}
               - anchor: #{rifAnchor ?: styleIfNeeded Faint "-"}
             |]
           FLRelative link ->
             [int||
-            reference #{paren $ colorIfNeeded Yellow "relative"} #{rPos}:
+            reference #{paren $ colorIfNeeded Yellow "relative"}#{posSep}#{rPos}:
               - text: #s{rName}
               - link: #{link}
               - anchor: #{rifAnchor ?: styleIfNeeded Faint "-"}
             |]
           FLAbsolute link ->
             [int||
-            reference #{paren $ colorIfNeeded Yellow "absolute"} #{rPos}:
+            reference #{paren $ colorIfNeeded Yellow "absolute"}#{posSep}#{rPos}:
               - text: #s{rName}
               - link: /#{link}
               - anchor: #{rifAnchor ?: styleIfNeeded Faint "-"}
             |]
       RIExternal (ELUrl url) ->
         [int||
-        reference #{paren $ colorIfNeeded Red "external"} #{rPos}:
+        reference #{paren $ colorIfNeeded Red "external"}#{posSep}#{rPos}:
           - text: #s{rName}
           - link: #{url}
         |]
       RIExternal (ELOther url) ->
         [int||
-        reference (other) #{rPos}:
+        reference (other)#{posSep}#{rPos}:
           - text: #s{rName}
           - link: #{url}
         |]
+    where
+      posSep :: Text
+      posSep = case rPos of
+        Position Nothing -> ""
+        _ -> " "
 
 instance Given ColorMode => Buildable AnchorType where
   build = styleIfNeeded Faint . \case

src/Xrefcheck/Scan.hs

@@ -10,26 +10,25 @@
 module Xrefcheck.Scan
   ( ExclusionConfig
   , ExclusionConfig' (..)
-  , Extension
-  , ScanAction
-  , FormatsSupport
+  , FileSupport
   , ReadDirectoryMode(..)
+  , ScanAction
   , ScanError (..)
   , ScanErrorDescription (..)
   , ScanResult (..)
   , ScanStage (..)
 
-  , mkParseScanError
-  , mkGatherScanError
-  , scanRepo
-  , specificFormatsSupport
   , defaultCompOption
   , defaultExecOption
   , ecIgnoreL
   , ecIgnoreLocalRefsToL
   , ecIgnoreRefsFromL
   , ecIgnoreExternalRefsToL
+  , firstFileSupport
+  , mkGatherScanError
+  , mkParseScanError
   , reportScanErrs
+  , scanRepo
   ) where
 
 import Universum
@@ -70,11 +69,14 @@ makeLensesWith postfixFields ''ExclusionConfig'
 -- | File extension, dot included.
 type Extension = String
 
+-- | Whether the file is a symlink.
+type IsSymlink = Bool
+
 -- | Way to parse a file.
 type ScanAction = FilePath -> RelPosixLink -> IO (FileInfo, [ScanError 'Parse])
 
 -- | All supported ways to parse a file.
-type FormatsSupport = Extension -> Maybe ScanAction
+type FileSupport = IsSymlink -> Extension -> Maybe ScanAction
 
 data ScanResult = ScanResult
   { srScanErrors :: [ScanError 'Gather]
@@ -153,14 +155,9 @@ instance Buildable ScanErrorDescription where
     UnrecognisedErr txt -> [int||Unrecognised option "#{txt}" perhaps you meant \
                                  <"ignore link"|"ignore paragraph"|"ignore all">|]
 
-specificFormatsSupport :: [([Extension], ScanAction)] -> FormatsSupport
-specificFormatsSupport formats = \ext -> M.lookup ext formatsMap
-  where
-    formatsMap = M.fromList
-        [ (extension, parser)
-        | (extensions, parser) <- formats
-        , extension <- extensions
-        ]
+firstFileSupport :: [FileSupport] -> FileSupport
+firstFileSupport fs isSymlink =
+  safeHead . catMaybes <$> traverse ($ isSymlink) fs
 
 data ReadDirectoryMode
   = RdmTracked
@@ -211,7 +208,7 @@ scanRepo
   :: MonadIO m
   => ScanPolicy
   -> Rewrite
-  -> FormatsSupport
+  -> FileSupport
   -> ExclusionConfig
   -> FilePath
   -> m ScanResult
@@ -228,12 +225,13 @@ scanRepo scanMode rw formatsSupport config root = do
     in  liftIO $ (gatherScanErrs &&& gatherFileStatuses)
           <$> readDirectoryWith mode config processFile root
 
-  notProcessedFiles <-  case scanMode of
+  notProcessedFiles <- case scanMode of
     OnlyTracked -> liftIO $
       readDirectoryWith RdmUntracked config (const $ pure NotAddedToGit) root
     IncludeUntracked -> pure []
 
-  let scannableNotProcessedFiles = filter (isJust . mscanner . fst) notProcessedFiles
+  scannableNotProcessedFiles <- liftIO $
+    filterM (fmap isJust . fileScanner . fst) notProcessedFiles
 
   whenJust (nonEmpty $ map fst scannableNotProcessedFiles) $ \files -> hPutStrLn @Text stderr
     [int|A|
@@ -252,8 +250,10 @@ scanRepo scanMode rw formatsSupport config root = do
         <> fmap (, UntrackedDirectory) untrackedDirs)
     }
   where
-    mscanner :: RelPosixLink -> Maybe ScanAction
-    mscanner = formatsSupport . takeExtension
+    fileScanner :: RelPosixLink -> IO (Maybe ScanAction)
+    fileScanner file = do
+      isSymlink <- pathIsSymbolicLink (filePathFromRoot root file)
+      pure $ formatsSupport isSymlink $ takeExtension file
 
     gatherScanErrs
       :: [(RelPosixLink, (FileStatus, [ScanError 'Parse]))]
@@ -267,10 +267,9 @@ scanRepo scanMode rw formatsSupport config root = do
     gatherFileStatuses = map (second fst)
 
     processFile :: RelPosixLink -> IO (FileStatus, [ScanError 'Parse])
-    processFile file =
-      ifM (pathIsSymbolicLink (filePathFromRoot root file))
-      (pure (NotScannable, []))
-      case mscanner file of
+    processFile file = do
+      mScanner <- fileScanner file
+      case mScanner of
         Nothing -> pure (NotScannable, [])
         Just scanner -> scanner root file <&> _1 %~ Scanned
 

src/Xrefcheck/Scanners/Markdown.hs

@@ -5,8 +5,7 @@
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
--- | Markdown documents markdownScanner.
-
+-- | Scanner for gathering references to verify from Markdown documents.
 module Xrefcheck.Scanners.Markdown
   ( MarkdownConfig (..)
 
@@ -410,5 +409,8 @@ markdownScanner config root file =
   parseFileInfo config . decodeUtf8
     <$> BSL.readFile (filePathFromRoot root file)
 
-markdownSupport :: MarkdownConfig -> ([Extension], ScanAction)
-markdownSupport config = ([".md"], markdownScanner config)
+markdownSupport :: MarkdownConfig -> FileSupport
+markdownSupport config isSymlink extension = do
+  guard $ extension == ".md"
+  guard $ not isSymlink
+  pure $ markdownScanner config

src/Xrefcheck/Scanners/Symlink.hs

@@ -0,0 +1,36 @@
+{- SPDX-FileCopyrightText: 2023 Serokell <https://serokell.io>
+ -
+ - SPDX-License-Identifier: MPL-2.0
+ -}
+
+-- | Scanner for gathering references to verify from symlinks.
+--
+-- A symlink's reference corresponds to the file it points to.
+module Xrefcheck.Scanners.Symlink
+  ( symlinkScanner
+  , symlinkSupport
+  ) where
+
+import Universum
+
+import System.Directory (getSymbolicLinkTarget)
+
+import Xrefcheck.Core
+import Xrefcheck.Scan
+import Xrefcheck.System
+
+symlinkScanner :: ScanAction
+symlinkScanner root path = do
+  rLink <- unRelPosixLink . mkRelPosixLink
+    <$> getSymbolicLinkTarget (filePathFromRoot root path)
+
+  let rName = "Symbolic Link"
+      rPos = Position Nothing
+      rInfo = referenceInfo rLink
+
+  pure (FileInfo [Reference {rName, rPos, rInfo}] [], [])
+
+symlinkSupport :: FileSupport
+symlinkSupport isSymlink _ = do
+  guard isSymlink
+  pure symlinkScanner

tests/Test/Xrefcheck/IgnoreRegexSpec.hs

@@ -16,16 +16,16 @@ import Text.Regex.TDFA (Regex)
 import Xrefcheck.Config
 import Xrefcheck.Core
 import Xrefcheck.Progress (allowRewrite)
-import Xrefcheck.Scan (ScanResult (..), ecIgnoreExternalRefsToL, scanRepo, specificFormatsSupport)
+import Xrefcheck.Scan
 import Xrefcheck.Scanners.Markdown
 import Xrefcheck.Util (ColorMode (WithoutColors))
-import Xrefcheck.Verify (VerifyError, VerifyResult, WithReferenceLoc (..), verifyErrors, verifyRepo)
+import Xrefcheck.Verify
 
 test_ignoreRegex :: TestTree
 test_ignoreRegex = give WithoutColors $
   let root = "tests/markdowns/without-annotations"
       showProgressBar = False
-      formats = specificFormatsSupport [markdownSupport defGithubMdConfig]
+      fileSupport = firstFileSupport [markdownSupport defGithubMdConfig]
       verifyMode = ExternalOnlyMode
 
       linksTxt =
@@ -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 fileSupport (config ^. cExclusionsL) root
 
       verifyRes <- allowRewrite showProgressBar $ \rw ->
         verifyRepo rw config verifyMode $ srRepoInfo scanResult

tests/Test/Xrefcheck/TrailingSlashSpec.hs

@@ -23,13 +23,13 @@ import Xrefcheck.Util
 test_slash :: TestTree
 test_slash = testGroup "Trailing forward slash detection" $
   let config = defConfig GitHub
-      format = specificFormatsSupport [markdownSupport (scMarkdown (cScanners config))]
+      fileSupport = firstFileSupport [markdownSupport (scMarkdown (cScanners config))]
   in roots <&> \root ->
     testCase ("All the files within the root \"" <>
       root <>
       "\" should exist") $ do
         (ScanResult _ RepoInfo{..}) <- allowRewrite False $ \rw ->
-          scanRepo OnlyTracked rw format (cExclusions config & ecIgnoreL .~ []) root
+          scanRepo OnlyTracked rw fileSupport (cExclusions config & ecIgnoreL .~ []) root
         nonExistentFiles <- lefts <$> forM (fst . snd <$> toPairs riFiles) (\file -> do
           predicate <- doesFileExist . filePathFromRoot root $ file
           return $ if predicate

tests/golden/check-autolinks/check-autolinks.bats

@@ -16,7 +16,7 @@ assert_diff - <<EOF
 
   file-with-autolinks.md:
     - references:
-        - reference (external) :
+        - reference (external):
             - text: "https://www.google.com/doodles"
             - link: https://www.google.com/doodles
         - reference (external) at src:8:0-18:

tests/golden/check-symlinks/check-symlinks.bats

@@ -10,8 +10,39 @@ load '../helpers/bats-file/load'
 load '../helpers'
 
 
-@test "Checking that symlinks are not processed" {
+@test "Checking that symlinks are not processed as md files" {
+  cp config-ignore.yaml $TEST_TEMP_DIR
+  cp expected1.gold $TEST_TEMP_DIR
+  cp -R dir $TEST_TEMP_DIR
+
+  cd $TEST_TEMP_DIR
+  touch dir/a
+  ln -s ../d.md outside.md
+  ln -s dir/b.md ok.md
+  ln -s dir/c.md broken.md
+
+  git init
+  git add ./*
+
+  to_temp xrefcheck -v -c config-ignore.yaml
+
+  assert_diff expected1.gold
+}
+
+@test "Symlinks validation" {
+  cp expected2.gold $TEST_TEMP_DIR
+  cp -R dir $TEST_TEMP_DIR
+
+  cd $TEST_TEMP_DIR
+  touch dir/a
+  ln -s ../d.md outside.md
+  ln -s dir/b.md ok.md
+  ln -s dir/c.md broken.md
+
+  git init
+  git add ./*
+
   to_temp xrefcheck -v
 
-  assert_diff expected.gold
+  assert_diff expected2.gold
 }

tests/golden/check-symlinks/config-ignore.yaml

@@ -0,0 +1,12 @@
+# SPDX-FileCopyrightText: 2023 Serokell <https://serokell.io>
+#
+# SPDX-License-Identifier: Unlicense
+
+exclusions:
+  ignore:
+    - broken.md
+    - outside.md
+
+scanners:
+  markdown:
+    flavor: GitHub

tests/golden/check-symlinks/dir/b.md

@@ -6,6 +6,4 @@
 
 [Empty file](a)
 
-[Symlink ref](../s.md)
-
-[Symlink ref with anchor](../s.md#a)
+[Some symlink](../ok.md)