content: {- SPDX-FileCopyrightText: 2018-2019 Serokell <https://serokell.io>
   -
   - SPDX-License-Identifier: MPL-2.0
   -}
  
  {-# OPTIONS_GHC -Wno-orphans #-}
  
  -- | Generalised repo scanner and analyser.
  
  module Xrefcheck.Scan
    ( ExclusionConfig
    , ExclusionConfig' (..)
    , FileSupport
    , ReadDirectoryMode(..)
    , ScanAction
    , ScanError (..)
    , ScanErrorDescription (..)
    , ScanResult (..)
    , ScanStage (..)
  
    , defaultCompOption
    , defaultExecOption
    , ecIgnoreL
    , ecIgnoreLocalRefsToL
    , ecIgnoreRefsFromL
    , ecIgnoreExternalRefsToL
    , firstFileSupport
    , mkGatherScanError
    , mkParseScanError
    , reportScanErrs
    , scanRepo
    ) where
  
  import Universum hiding (_1, (%~))
  
  import Control.Lens (_1, makeLensesWith, (%~))
  import Data.Aeson (FromJSON (..), genericParseJSON, withText)
  import Data.Map qualified as M
  import Data.Reflection (Given)
  import Fmt (Buildable (..), Builder, fmtLn)
  import System.Directory (doesDirectoryExist, pathIsSymbolicLink)
  import System.Process (cwd, proc, readCreateProcess)
  import Text.Interpolation.Nyan
  import Text.Regex.TDFA.Common (CompOption (..), ExecOption (..), Regex)
  import Text.Regex.TDFA.Text qualified as R
  
  import Xrefcheck.Core
  import Xrefcheck.Progress
  import Xrefcheck.System
  import Xrefcheck.Util
  
  -- | Type alias for ExclusionConfig' with all required fields.
  type ExclusionConfig = ExclusionConfig' Identity
  
  -- | Config of repositry exclusions.
  data ExclusionConfig' f = ExclusionConfig
    { ecIgnore               :: Field f [CanonicalRelGlobPattern]
      -- ^ Files which we completely ignore.
    , ecIgnoreLocalRefsTo    :: Field f [CanonicalRelGlobPattern]
      -- ^ Files references to which we do not verify.
    , ecIgnoreRefsFrom       :: Field f [CanonicalRelGlobPattern]
      -- ^ Files, references in which we should not analyze.
    , ecIgnoreExternalRefsTo :: Field f [Regex]
      -- ^ Regular expressions that match external references we should not verify.
    } deriving stock (Generic)
  
  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 FileSupport = IsSymlink -> Extension -> Maybe ScanAction
  
  data ScanResult = ScanResult
    { srScanErrors :: [ScanError 'Gather]
    , srRepoInfo   :: RepoInfo
    }
  
  -- | A scan error indexed by different process stages.
  --
  -- 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
    }
  
  data ScanStage = Parse | Gather
  
  type family ScanStageFile (a :: ScanStage) where
    ScanStageFile 'Parse = ()
    ScanStageFile 'Gather = RelPosixLink
  
  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 :: RelPosixLink ->  ScanError 'Parse -> ScanError 'Gather
  mkGatherScanError seFile ScanError{sePosition, seDescription} = ScanError
    { seFile
    , sePosition
    , seDescription
    }
  
  pprScanErr :: Given ColorMode => ScanError 'Gather -> Builder
  pprScanErr ScanError{..} = hdr <> "\n" <> interpolateIndentF 2 msg <> "\n"
    where
      hdr, msg :: Builder
      hdr =
        styleIfNeeded Bold (build sePosition <> ": ") <>
        colorIfNeeded Red "scan error:"
      msg = build seDescription
  
  reportScanErrs :: Given ColorMode => NonEmpty (ScanError 'Gather) -> IO ()
  reportScanErrs errs = do
    traverse_ (fmtLn . pprScanErr) errs
    fmtLn $ colorIfNeeded Red $
      "Scan errors dumped, " <> build (length errs) <> " in total."
  
  data ScanErrorDescription
    = LinkErr
    | FileErr
    | ParagraphErr Text
    | UnrecognisedErr Text
    deriving stock (Show, Eq)
  
  instance Buildable ScanErrorDescription where
    build = \case
      LinkErr -> [int||Expected a LINK after "ignore link" annotation|]
      FileErr -> [int||Annotation "ignore all" must be at the top of \
                       markdown or right after comments at the top|]
      ParagraphErr txt -> [int||Expected a PARAGRAPH after \
                                "ignore paragraph" annotation, but found #{txt}|]
      UnrecognisedErr txt -> [int||Unrecognised option "#{txt}"
                                   Perhaps you meant <"ignore link"|"ignore paragraph"|"ignore all">|]
  
  firstFileSupport :: [FileSupport] -> FileSupport
  firstFileSupport fs isSymlink =
    safeHead . catMaybes <$> traverse ($ isSymlink) fs
  
  data ReadDirectoryMode
    = RdmTracked
    -- ^ Consider files tracked by Git, obtained from "git ls-files"
    | RdmUntracked
    -- ^ Consider files that are not tracked nor ignored by Git, obtained from
    -- "git ls-files --others --exclude-standard"
    | RdmBothTrackedAndUtracked
    -- ^ Combine output from commands listed above, so we consider all files
    -- except ones that are explicitly ignored by Git
  
  -- | Process files that match given @ReadDirectoryMode@ and aren't ignored by the config.
  readDirectoryWith
    :: forall a. ReadDirectoryMode
    -> ExclusionConfig
    -> (RelPosixLink -> IO a)
    -> FilePath
    -> IO [(RelPosixLink, a)]
  readDirectoryWith mode config scanner root = do
    relativeFiles <- fmap mkRelPosixLink . fileLines <$> getFiles
    traverse scanFile $ filter (not . isIgnored) relativeFiles
  
    where
  
      getFiles = case mode of
        RdmTracked -> getTrackedFiles
        RdmUntracked -> getUntrackedFiles
        RdmBothTrackedAndUtracked -> liftA2 (<>) getTrackedFiles getUntrackedFiles
  
      getTrackedFiles = readCreateProcess
        (proc "git" ["ls-files", "-z"]){cwd = Just root} ""
      getUntrackedFiles = readCreateProcess
        (proc "git" ["ls-files", "-z", "--others", "--exclude-standard"]){cwd = Just root} ""
  
      fileLines :: String -> [String]
      fileLines (dropWhile (== '\0') -> ls) =
        case break (== '\0') ls of
          ([], _) -> []
          (f, ls') -> f : fileLines ls'
  
      scanFile :: RelPosixLink -> IO (RelPosixLink, a)
      scanFile c = (c,) <$> scanner c
  
      isIgnored :: RelPosixLink -> Bool
      isIgnored = matchesGlobPatterns (ecIgnore config) . canonicalizeRelPosixLink
  
  scanRepo
    :: MonadIO m
    => ScanPolicy
    -> Rewrite
    -> FileSupport
    -> ExclusionConfig
    -> FilePath
    -> m ScanResult
  scanRepo scanMode rw formatsSupport config root = do
    putTextRewrite rw "Scanning repository..."
  
    liftIO $ whenM (not <$> doesDirectoryExist root) $
      die $ "Repository's root does not seem to be a directory: " <> root
  
    (errs, processedFiles) <-
      let mode = case scanMode of
            OnlyTracked -> RdmTracked
            IncludeUntracked -> RdmBothTrackedAndUtracked
      in  liftIO $ (gatherScanErrs &&& gatherFileStatuses)
            <$> readDirectoryWith mode config processFile root
  
    notProcessedFiles <- case scanMode of
      OnlyTracked -> liftIO $
        readDirectoryWith RdmUntracked config (const $ pure NotAddedToGit) root
      IncludeUntracked -> pure []
  
    scannableNotProcessedFiles <- liftIO $
      filterM (fmap isJust . fileScanner . fst) notProcessedFiles
  
    whenJust (nonEmpty $ map fst scannableNotProcessedFiles) $ \files -> hPutStrLn @Text stderr
      [int|A|
      Those files are not added by Git, so we're not scanning them:
      #{interpolateBlockListF files}
      Please run "git add" before running xrefcheck or enable \
      --include-untracked CLI option to check these files.
      |]
  
    let trackedDirs = foldMap (getIntermediateDirs . fst) processedFiles
        untrackedDirs = foldMap (getIntermediateDirs . fst) notProcessedFiles
  
    return . ScanResult errs $ RepoInfo
      { riFiles = M.fromList $ fmap canonicalLinkEntry $ processedFiles <> notProcessedFiles
      , riDirectories = M.fromList $ fmap canonicalLinkEntry (fmap (, TrackedDirectory) trackedDirs
          <> fmap (, UntrackedDirectory) untrackedDirs)
      }
    where
      fileScanner :: RelPosixLink -> IO (Maybe ScanAction)
      fileScanner file = do
        isSymlink <- pathIsSymbolicLink (filePathFromRoot root file)
        pure $ formatsSupport isSymlink $ takeExtension file
  
      gatherScanErrs
        :: [(RelPosixLink, (FileStatus, [ScanError 'Parse]))]
        -> [ScanError 'Gather]
      gatherScanErrs = foldMap $ \(file, (_, errs)) ->
        mkGatherScanError file <$> errs
  
      gatherFileStatuses
        :: [(RelPosixLink, (FileStatus, [ScanError 'Parse]))]
        -> [(RelPosixLink, FileStatus)]
      gatherFileStatuses = map (second fst)
  
      processFile :: RelPosixLink -> IO (FileStatus, [ScanError 'Parse])
      processFile file = do
        mScanner <- fileScanner file
        case mScanner of
          Nothing -> pure (NotScannable, [])
          Just scanner -> scanner root file <&> _1 %~ Scanned
  
      canonicalLinkEntry
        :: (RelPosixLink, a)
        -> (CanonicalRelPosixLink, (RelPosixLink, a))
      canonicalLinkEntry (a, b) = (canonicalizeRelPosixLink a, (a, b))
  
  -----------------------------------------------------------
  -- Yaml instances
  -----------------------------------------------------------
  
  instance FromJSON Regex where
    parseJSON = withText "regex" $ \val -> do
      let errOrRegex = R.compile defaultCompOption defaultExecOption val
      either (error . show) return errOrRegex
  
  -- Default boolean values according to
  -- https://hackage.haskell.org/package/regex-tdfa-1.3.1.0/docs/Text-Regex-TDFA.html#t:CompOption
  defaultCompOption :: CompOption
  defaultCompOption = CompOption
    { caseSensitive = True
    , multiline = True
    , rightAssoc = True
    , newSyntax = True
    , lastStarGreedy = False
    }
  
  -- ExecOption value to improve speed
  defaultExecOption :: ExecOption
  defaultExecOption = ExecOption {captureGroups = False}
  
  instance FromJSON (ExclusionConfig' Maybe) where
    parseJSON = genericParseJSON aesonConfigOption
  
  instance FromJSON (ExclusionConfig) where
    parseJSON = genericParseJSON aesonConfigOption
  