[#64] Implement copy paste protection

CHANGES.md

@@ -41,6 +41,8 @@ Unreleased
 * [#231](https://github.com/serokell/xrefcheck/pull/231)
   + Anchor analysis takes now into account the appropriate case-sensitivity depending on
   the configured Markdown flavour.
+* [#245](https://github.com/serokell/xrefcheck/pull/245)
+  + Now xrefcheck is able to detect possible copy-pastes relying on links and their names.
 
 0.2.2
 ==========

README.md

@@ -44,6 +44,7 @@ Comparing to alternative solutions, this tool tries to achieve the following poi
 * Supports relative and absolute local links.
 * Supports external links (`http`, `https`, `ftp` and `ftps`).
 * Detects broken and ambiguous anchors in local links.
+* Detects possible bad copy-pastes of links.
 * Integration with GitHub Actions.
 
 ## Dependencies [↑](#xrefcheck)
@@ -148,6 +149,16 @@ There are several ways to fix this:
     * By default, `xrefcheck` will ignore links to localhost.
     * This behavior can be disabled by removing the corresponding entry from the `ignoreExternalRefsTo` list in the config file.
 
+1. How does the copy-paste check work?
+    * If there are some references with the same links and for one of them name is similar to the link itself, other links may turn out to be copypasted from that link. Example:
+      ```md
+      Links with bad copypaste:
+      [good link](https://good.link.uri/).
+      [copypasted link](https://good.link.uri/).
+      ```
+      The second link will be reported by `xrefcheck` as a possible bad copy-paste of the first link.
+    * This checks both external references and local ones.
+
 ## Further work [↑](#xrefcheck)
 
 - [ ] Support link detection in different languages, not only Markdown.

src/Xrefcheck/Command.hs

@@ -28,7 +28,7 @@ import Xrefcheck.Scan
 import Xrefcheck.Scanners.Markdown (markdownSupport)
 import Xrefcheck.System (askWithinCI)
 import Xrefcheck.Util
-import Xrefcheck.Verify (reportVerifyErrs, verifyErrors, verifyRepo)
+import Xrefcheck.Verify (reportCopyPasteErrors, reportVerifyErrs, verifyErrors, verifyRepo)
 
 readConfig :: FilePath -> IO Config
 readConfig path = fmap (normaliseConfigFilePaths . overrideConfig) do
@@ -81,11 +81,12 @@ defaultAction Options{..} = do
 
     whenJust (nonEmpty $ sortBy (compare `on` seFile) scanErrs) $ reportScanErrs
 
-    verifyRes <- allowRewrite showProgressBar $ \rw -> do
+    (verifyRes, copyPasteErrors) <- allowRewrite showProgressBar $ \rw -> do
       let fullConfig = config
             { cNetworking = addNetworkingOptions (cNetworking config) oNetworkingOptions }
       verifyRepo rw fullConfig oMode oRoot repoInfo
 
+    whenJust (nonEmpty copyPasteErrors) reportCopyPasteErrors
     case verifyErrors verifyRes of
       Nothing | null scanErrs -> fmtLn "All repository links are valid."
       Nothing -> exitFailure

src/Xrefcheck/Config.hs

@@ -73,6 +73,8 @@ data ScannersConfig' f = ScannersConfig
   , scAnchorSimilarityThreshold :: Field f Double
     -- ^ On 'anchor not found' error, how much similar anchors should be displayed as
     -- hint. Number should be between 0 and 1, larger value means stricter filter.
+  , scCopyPasteCheckEnabled :: Field f Bool
+    -- ^ Whether copy-paste check is enabled globally.
   } deriving stock (Generic)
 
 makeLensesWith postfixFields ''Config'
@@ -94,6 +96,9 @@ overrideConfig config
                   , scAnchorSimilarityThreshold =
                     fromMaybe (scAnchorSimilarityThreshold defScanners)
                     $ scAnchorSimilarityThreshold (cScanners config)
+                  , scCopyPasteCheckEnabled =
+                    fromMaybe (scCopyPasteCheckEnabled defScanners)
+                    $ scCopyPasteCheckEnabled (cScanners config)
                   }
     }
   where

src/Xrefcheck/Config/Default.hs

@@ -67,6 +67,9 @@ scanners:
     #
     # This affects which anchors are generated for headers.
     flavor: #s{flavor}
+
+  # Whether the copy-paste check is enabled globally.
+  copyPasteCheckEnabled: true
 |]
   where
     ignoreLocalRefsFrom :: NonEmpty Text

src/Xrefcheck/Core.hs

@@ -61,7 +61,7 @@ instance FromJSON Flavor where
 -- We keep this in text because scanners for different formats use different
 -- representation of this thing, and it actually appears in reports only.
 newtype Position = Position (Maybe Text)
-  deriving stock (Show, Eq, Generic)
+  deriving stock (Show, Eq, Generic, Ord)
 
 instance Given ColorMode => Buildable Position where
   build (Position pos) = case pos of
@@ -77,7 +77,7 @@ data Reference = Reference
   , rAnchor :: Maybe Text
     -- ^ Section or custom anchor tag.
   , rPos    :: Position
-  } deriving stock (Show, Generic)
+  } deriving stock (Show, Generic, Eq, Ord)
 
 -- | Context of anchor.
 data AnchorType

src/Xrefcheck/Verify.hs

@@ -26,20 +26,32 @@ module Xrefcheck.Verify
   , verifyReference
   , checkExternalResource
 
+    -- * Copypaste check
+  , checkCopyPaste
+  , CopyPasteCheckResult (..)
+
     -- * URI parsing
   , parseUri
+
+    -- * Reporting errors
   , reportVerifyErrs
+  , reportCopyPasteErrors
   ) where
 
 import Universum
 
 import Control.Concurrent.Async (Async, async, cancel, poll, wait, withAsync)
 import Control.Exception (AsyncException (..), throwIO)
+import Control.Exception.Safe (handleAsync, handleJust)
 import Control.Monad.Except (MonadError (..))
+import Data.Bits (toIntegralSized)
 import Data.ByteString qualified as BS
+import Data.Char (isAlphaNum)
 import Data.List qualified as L
 import Data.Map qualified as M
 import Data.Reflection (Given)
+import Data.Text (toCaseFold)
+import Data.Text qualified as T
 import Data.Text.Metrics (damerauLevenshteinNorm)
 import Data.Time (UTCTime, defaultTimeLocale, formatTime, readPTime, rfc822DateFormat)
 import Data.Time.Clock.POSIX (getPOSIXTime)
@@ -66,10 +78,6 @@ import Text.URI (Authority (..), ParseExceptionBs, URI (..), mkURIBs)
 import Time (RatioNat, Second, Time (..), ms, sec, threadDelay, timeout, (+:+), (-:-))
 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.Core
 import Xrefcheck.Orphans ()
@@ -255,6 +263,21 @@ instance Given ColorMode => Buildable VerifyError where
         #{redirectedUrl}
       |]
 
+data CopyPasteCheckResult = CopyPasteCheckResult
+  { crFile :: FilePath
+  , crOriginalRef :: Reference
+  , crCopiedRef :: Reference
+  } deriving stock (Show, Eq, Ord)
+
+instance (Given ColorMode) => Buildable CopyPasteCheckResult where
+  build CopyPasteCheckResult {..} =
+    [int||
+    In file #{styleIfNeeded Faint (styleIfNeeded Bold crFile)}
+    #{crCopiedRef}\
+    is possibly a bad copy paste of
+    #{crOriginalRef}
+    |]
+
 reportVerifyErrs
   :: Given ColorMode => NonEmpty (WithReferenceLoc VerifyError) -> IO ()
 reportVerifyErrs errs = fmt
@@ -265,6 +288,15 @@ reportVerifyErrs errs = fmt
   Invalid references dumped, #{length errs} in total.
   |]
 
+reportCopyPasteErrors
+  :: Given ColorMode => NonEmpty CopyPasteCheckResult -> IO ()
+reportCopyPasteErrors errs = fmt
+  [int||
+  === Possible copy/paste errors ===
+
+  #{interpolateIndentF 2 (interpolateBlockListF' "➥ " build errs)}
+  Possible copy/paste errors dumped, #{length errs} in total.
+  |]
 
 data RetryAfter = Date UTCTime | Seconds (Time Second)
   deriving stock (Show, Eq)
@@ -355,32 +387,42 @@ verifyRepo
   -> VerifyMode
   -> FilePath
   -> RepoInfo
-  -> IO (VerifyResult $ WithReferenceLoc VerifyError)
+  -> IO (VerifyResult $ WithReferenceLoc VerifyError, [CopyPasteCheckResult])
 verifyRepo
   rw
   config@Config{..}
   mode
   root
   repoInfo'@(RepoInfo files _)
     = do
-  let toScan = do
-        (file, fileInfo) <- M.toList files
+
+  let filesToScan = flip mapMaybe (M.toList files) $ \(file, fileInfo) -> do
         guard . not $ matchesGlobPatterns root (ecIgnoreRefsFrom cExclusions) file
         case fileInfo of
           Scanned fi -> do
-            ref <- _fiReferences fi
-            return (file, ref)
-          NotScannable -> empty -- No support for such file, can do nothing.
-          NotAddedToGit -> empty -- If this file is scannable, we've notified
+            Just (file, fi)
+          NotScannable -> Nothing -- No support for such file, can do nothing.
+          NotAddedToGit -> Nothing -- If this file is scannable, we've notified
                                  -- user that we are scanning only files
                                  -- added to Git while gathering RepoInfo.
 
+      toCheckCopyPaste = map (second _fiReferences) filesToScan
+      toScan = concatMap (\(file, fileInfo) -> map (file,) $ _fiReferences fileInfo) filesToScan
+      copyPasteErrors =
+        if scCopyPasteCheckEnabled cScanners
+          then
+            [ res
+            | (file, refs) <- toCheckCopyPaste,
+              res <- checkCopyPaste file refs
+            ]
+          else []
+
   progressRef <- newIORef $ initVerifyProgress (map snd toScan)
 
   accumulated <- loopAsyncUntil (printer progressRef) do
     forConcurrentlyCaching toScan ifExternalThenCache $ \(file, ref) ->
       verifyReference config mode progressRef repoInfo' root file ref
-  case accumulated of
+  (, copyPasteErrors) <$> case accumulated of
     Right res -> return $ fold res
     Left (exception, partialRes) -> do
       -- The user has hit Ctrl+C; display any verification errors we managed to find and exit.
@@ -412,6 +454,40 @@ verifyRepo
       ExternalLoc -> CacheUnderKey rLink
       _           -> NoCaching
 
+checkCopyPaste :: FilePath -> [Reference] -> [CopyPasteCheckResult]
+checkCopyPaste file refs = do
+  let getLinkAndAnchor x = (rLink x, rAnchor x)
+      groupedRefs =
+          L.groupBy ((==) `on` getLinkAndAnchor) $
+          sortBy (compare `on` getLinkAndAnchor) refs
+  concatMap checkGroup groupedRefs
+  where
+    checkGroup :: [Reference] -> [CopyPasteCheckResult]
+    checkGroup refsInGroup = do
+      let mergeLinkAndAnchor ref = maybe (rLink ref) (rLink ref <>) $ rAnchor ref
+      let refsInGroup' = refsInGroup <&> \ref ->
+            (ref, (prepareNameForCheck $ rName ref,
+                   prepareNameForCheck $ mergeLinkAndAnchor ref))
+      let (mbSubstrRef, others) =
+            bimap (fmap fst . safeHead) (map fst) $
+              L.partition (textIsLinkSubstr . snd) refsInGroup'
+      maybe [] (\substrRef -> map (CopyPasteCheckResult file substrRef) others) mbSubstrRef
+
+    textIsLinkSubstr :: (Text, Text) -> Bool
+    textIsLinkSubstr (prepName, prepLink) = prepName `isSubSeq` prepLink
+
+    prepareNameForCheck :: Text -> Text
+    prepareNameForCheck = T.toLower . T.filter isAlphaNum
+
+    isSubSeq :: Text -> Text -> Bool
+    isSubSeq "" _str = True
+    isSubSeq _que "" = False
+    isSubSeq que str
+      | qhead == shead = isSubSeq qtail stail
+      | otherwise      = isSubSeq que stail
+      where (qhead, qtail) = T.splitAt 1 que
+            (shead, stail) = T.splitAt 1 str
+
 shouldCheckLocType :: VerifyMode -> LocationType -> Bool
 shouldCheckLocType mode locType
   | isExternal locType = shouldCheckExternal mode
@@ -752,7 +828,7 @@ checkExternalResource Config{..} link
             | isPermanentRedirectCode code -> Left
               . PermanentRedirectError link
               . fmap decodeUtf8
-              . lookup "Location"
+              . L.lookup "Location"
               $ responseHeaders resp
             | isTemporaryRedirectCode code -> Right ()
             | isAllowedErrorCode code -> Right ()

tests/Test/Xrefcheck/CopyPasteCheckSpec.hs

@@ -0,0 +1,65 @@
+{- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>
+ -
+ - SPDX-License-Identifier: MPL-2.0
+ -}
+
+module Test.Xrefcheck.CopyPasteCheckSpec where
+
+import Universum
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (Assertion, testCase, (@?=))
+
+import Xrefcheck.Core
+import Xrefcheck.Verify
+
+assertUnordered :: (Show a, Ord a) => [a] -> [a] -> Assertion
+assertUnordered = (@?=) `on` sort
+
+testPath :: FilePath
+testPath = "test-path"
+
+test_copyPasteCheck :: TestTree
+test_copyPasteCheck = testGroup "Copypaste check"
+  [ testCase "Detect copypaste error if there is a link with a matching name" $ do
+      let link = "./first-file"
+          anchor = Just "heading"
+          differentAnchor = Nothing
+          defPos = Position Nothing
+          original1 = Reference "_-  First -  - File" link anchor defPos
+          original2 = Reference "_-  First - fi - le" link anchor defPos
+          notCopied = Reference " Link 2 " link differentAnchor defPos
+          copied1 = Reference " foo bar" link anchor defPos
+          copied2 = Reference " Baz quux" link anchor defPos
+          input = [original1, original2, notCopied, copied1, copied2]
+          res = checkCopyPaste testPath input
+          expectedRes =
+          -- only first matching link is shown in the output
+            [ CopyPasteCheckResult testPath original1 copied1
+            , CopyPasteCheckResult testPath original1 copied2
+            ]
+      res `assertUnordered` expectedRes
+  , testCase "Succeed if there is not link with a matching name" $ do
+      let link = "./first-file"
+          anchor = Just "heading"
+          defPos = Position Nothing
+          original1 = Reference "_Foo bar" link anchor defPos
+          original2 = Reference " Baz quux" link anchor defPos
+          original3 = Reference " Foo qubarx" link anchor defPos
+          input = [original1, original2, original3]
+          res = checkCopyPaste testPath input
+          expectedRes = []
+      res @?= expectedRes
+  , testCase "Check external links" $ do
+      let link = "https://github.com"
+          anchor = Nothing
+          defPos = Position Nothing
+          original = Reference "github" link anchor defPos
+          copied = Reference "gitlab" link anchor defPos
+          input = [original, copied]
+          res = checkCopyPaste testPath input
+          expectedRes =
+            [ CopyPasteCheckResult testPath original copied
+            ]
+      res @?= expectedRes
+  ]

tests/Test/Xrefcheck/IgnoreRegexSpec.hs

@@ -44,7 +44,7 @@ test_ignoreRegex = give WithoutColors $
       verifyRes <- allowRewrite showProgressBar $ \rw ->
         verifyRepo rw config verifyMode root $ srRepoInfo scanResult
 
-      let brokenLinks = pickBrokenLinks verifyRes
+      let brokenLinks = pickBrokenLinks $ fst verifyRes
 
       let matchedLinks =
             [ "https://bad.referenc/"

tests/configs/github-config.yaml

@@ -56,3 +56,6 @@ scanners:
     #
     # This affects which anchors are generated for headers.
     flavor: GitHub
+
+  # Whether the copy-paste check is enabled globally.
+  copyPasteCheckEnabled: true

tests/golden/check-copy-paste/check-copy-paste.bats

@@ -0,0 +1,17 @@
+#!/usr/bin/env bats
+
+# SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io>
+#
+# SPDX-License-Identifier: MPL-2.0
+
+load '../helpers/bats-support/load'
+load '../helpers/bats-assert/load'
+load '../helpers/bats-file/load'
+load '../helpers'
+
+
+@test "Check possible copy-paste errors and copy-paste annotations " {
+  to_temp xrefcheck
+
+  assert_diff expected.gold
+}