{- 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, readCreateProcess, shell)
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
  { forall (f :: * -> *).
ExclusionConfig' f -> Field f [CanonicalRelGlobPattern]
ecIgnore               :: Field f [CanonicalRelGlobPattern]
    -- ^ Files which we completely ignore.
  , forall (f :: * -> *).
ExclusionConfig' f -> Field f [CanonicalRelGlobPattern]
ecIgnoreLocalRefsTo    :: Field f [CanonicalRelGlobPattern]
    -- ^ Files references to which we do not verify.
  , forall (f :: * -> *).
ExclusionConfig' f -> Field f [CanonicalRelGlobPattern]
ecIgnoreRefsFrom       :: Field f [CanonicalRelGlobPattern]
    -- ^ Files, references in which we should not analyze.
  , forall (f :: * -> *). ExclusionConfig' f -> Field f [Regex]
ecIgnoreExternalRefsTo :: Field f [Regex]
    -- ^ Regular expressions that match external references we should not verify.
  } deriving stock ((forall x. ExclusionConfig' f -> Rep (ExclusionConfig' f) x)
-> (forall x. Rep (ExclusionConfig' f) x -> ExclusionConfig' f)
-> Generic (ExclusionConfig' f)
forall x. Rep (ExclusionConfig' f) x -> ExclusionConfig' f
forall x. ExclusionConfig' f -> Rep (ExclusionConfig' f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: * -> *) x.
Rep (ExclusionConfig' f) x -> ExclusionConfig' f
forall (f :: * -> *) x.
ExclusionConfig' f -> Rep (ExclusionConfig' f) x
$cfrom :: forall (f :: * -> *) x.
ExclusionConfig' f -> Rep (ExclusionConfig' f) x
from :: forall x. ExclusionConfig' f -> Rep (ExclusionConfig' f) x
$cto :: forall (f :: * -> *) x.
Rep (ExclusionConfig' f) x -> ExclusionConfig' f
to :: forall x. Rep (ExclusionConfig' f) x -> ExclusionConfig' f
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
  { ScanResult -> [ScanError 'Gather]
srScanErrors :: [ScanError 'Gather]
  , ScanResult -> RepoInfo
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
  { forall (a :: ScanStage). ScanError a -> ScanStageFile a
seFile        :: ScanStageFile a
  , forall (a :: ScanStage). ScanError a -> Position
sePosition    :: Position
  , forall (a :: ScanStage). ScanError a -> ScanErrorDescription
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 :: Position -> ScanErrorDescription -> ScanError 'Parse
mkParseScanError = ScanStageFile 'Parse
-> Position -> ScanErrorDescription -> ScanError 'Parse
forall (a :: ScanStage).
ScanStageFile a -> Position -> ScanErrorDescription -> ScanError a
ScanError ()

-- | Promote a 'ScanError' from the 'Parse' stage
-- to the 'Gather' stage.
mkGatherScanError :: RelPosixLink ->  ScanError 'Parse -> ScanError 'Gather
mkGatherScanError :: RelPosixLink -> ScanError 'Parse -> ScanError 'Gather
mkGatherScanError RelPosixLink
seFile ScanError{Position
sePosition :: forall (a :: ScanStage). ScanError a -> Position
sePosition :: Position
sePosition, ScanErrorDescription
seDescription :: forall (a :: ScanStage). ScanError a -> ScanErrorDescription
seDescription :: ScanErrorDescription
seDescription} = ScanError
  { RelPosixLink
ScanStageFile 'Gather
seFile :: ScanStageFile 'Gather
seFile :: RelPosixLink
seFile
  , Position
sePosition :: Position
sePosition :: Position
sePosition
  , ScanErrorDescription
seDescription :: ScanErrorDescription
seDescription :: ScanErrorDescription
seDescription
  }

pprScanErr :: Given ColorMode => ScanError 'Gather -> Builder
pprScanErr :: Given ColorMode => ScanError 'Gather -> Builder
pprScanErr ScanError{Position
ScanErrorDescription
ScanStageFile 'Gather
seFile :: forall (a :: ScanStage). ScanError a -> ScanStageFile a
sePosition :: forall (a :: ScanStage). ScanError a -> Position
seDescription :: forall (a :: ScanStage). ScanError a -> ScanErrorDescription
seFile :: ScanStageFile 'Gather
sePosition :: Position
seDescription :: ScanErrorDescription
..} = Builder
hdr Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Int -> Builder -> Builder
Int -> Builder -> Builder
interpolateIndentF Int
2 Builder
msg Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n"
  where
    hdr, msg :: Builder
    hdr :: Builder
hdr =
      Style -> Builder -> Builder
forall a. (Pretty a, Given ColorMode) => Style -> a -> a
styleIfNeeded Style
Bold (Position -> Builder
forall p. Buildable p => p -> Builder
build Position
sePosition Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
": ") Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
      Color -> Builder -> Builder
forall a. (Pretty a, Given ColorMode) => Color -> a -> a
colorIfNeeded Color
Red Builder
"scan error:"
    msg :: Builder
msg = ScanErrorDescription -> Builder
forall p. Buildable p => p -> Builder
build ScanErrorDescription
seDescription

reportScanErrs :: Given ColorMode => NonEmpty (ScanError 'Gather) -> IO ()
reportScanErrs :: Given ColorMode => NonEmpty (ScanError 'Gather) -> IO ()
reportScanErrs NonEmpty (ScanError 'Gather)
errs = do
  (Element (NonEmpty (ScanError 'Gather)) -> IO ())
-> NonEmpty (ScanError 'Gather) -> IO ()
forall t (f :: * -> *) b.
(Container t, Applicative f) =>
(Element t -> f b) -> t -> f ()
traverse_ (Builder -> IO ()
forall b. FromBuilder b => Builder -> b
fmtLn (Builder -> IO ())
-> (ScanError 'Gather -> Builder) -> ScanError 'Gather -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Given ColorMode => ScanError 'Gather -> Builder
ScanError 'Gather -> Builder
pprScanErr) NonEmpty (ScanError 'Gather)
errs
  Builder -> IO ()
forall b. FromBuilder b => Builder -> b
fmtLn (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ Color -> Builder -> Builder
forall a. (Pretty a, Given ColorMode) => Color -> a -> a
colorIfNeeded Color
Red (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$
    Builder
"Scan errors dumped, " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
forall p. Buildable p => p -> Builder
build (NonEmpty (ScanError 'Gather) -> Int
forall t. Container t => t -> Int
length NonEmpty (ScanError 'Gather)
errs) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" in total."

data ScanErrorDescription
  = LinkErr
  | FileErr
  | ParagraphErr Text
  | UnrecognisedErr Text
  deriving stock (Int -> ScanErrorDescription -> ShowS
[ScanErrorDescription] -> ShowS
ScanErrorDescription -> Extension
(Int -> ScanErrorDescription -> ShowS)
-> (ScanErrorDescription -> Extension)
-> ([ScanErrorDescription] -> ShowS)
-> Show ScanErrorDescription
forall a.
(Int -> a -> ShowS) -> (a -> Extension) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScanErrorDescription -> ShowS
showsPrec :: Int -> ScanErrorDescription -> ShowS
$cshow :: ScanErrorDescription -> Extension
show :: ScanErrorDescription -> Extension
$cshowList :: [ScanErrorDescription] -> ShowS
showList :: [ScanErrorDescription] -> ShowS
Show, ScanErrorDescription -> ScanErrorDescription -> Bool
(ScanErrorDescription -> ScanErrorDescription -> Bool)
-> (ScanErrorDescription -> ScanErrorDescription -> Bool)
-> Eq ScanErrorDescription
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScanErrorDescription -> ScanErrorDescription -> Bool
== :: ScanErrorDescription -> ScanErrorDescription -> Bool
$c/= :: ScanErrorDescription -> ScanErrorDescription -> Bool
/= :: ScanErrorDescription -> ScanErrorDescription -> Bool
Eq)

instance Buildable ScanErrorDescription where
  build :: ScanErrorDescription -> Builder
build = \case
    ScanErrorDescription
LinkErr -> [int||Expected a LINK after "ignore link" annotation|]
    ScanErrorDescription
FileErr -> [int||Annotation "ignore all" must be at the top of \
                     markdown or right after comments at the top|]
    ParagraphErr Text
txt -> [int||Expected a PARAGRAPH after \
                              "ignore paragraph" annotation, but found #{txt}|]
    UnrecognisedErr Text
txt -> [int||Unrecognised option "#{txt}"
                                 Perhaps you meant <"ignore link"|"ignore paragraph"|"ignore all">|]

firstFileSupport :: [FileSupport] -> FileSupport
firstFileSupport :: [FileSupport] -> FileSupport
firstFileSupport [FileSupport]
fs Bool
isSymlink =
  [ScanAction] -> Maybe (Element [ScanAction])
[ScanAction] -> Maybe ScanAction
forall t. Container t => t -> Maybe (Element t)
safeHead ([ScanAction] -> Maybe ScanAction)
-> ([Maybe ScanAction] -> [ScanAction])
-> [Maybe ScanAction]
-> Maybe ScanAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe ScanAction] -> [ScanAction]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe ScanAction] -> Maybe ScanAction)
-> (Extension -> [Maybe ScanAction])
-> Extension
-> Maybe ScanAction
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FileSupport -> Extension -> Maybe ScanAction)
-> [FileSupport] -> Extension -> [Maybe ScanAction]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (FileSupport -> FileSupport
forall a b. (a -> b) -> a -> b
$ Bool
isSymlink) [FileSupport]
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 :: forall a.
ReadDirectoryMode
-> ExclusionConfig
-> (RelPosixLink -> IO a)
-> Extension
-> IO [(RelPosixLink, a)]
readDirectoryWith ReadDirectoryMode
mode ExclusionConfig
config RelPosixLink -> IO a
scanner Extension
root = do
  [RelPosixLink]
relativeFiles <- (Extension -> RelPosixLink) -> [Extension] -> [RelPosixLink]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Extension -> RelPosixLink
mkRelPosixLink ([Extension] -> [RelPosixLink])
-> (Extension -> [Extension]) -> Extension -> [RelPosixLink]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Extension -> [Extension]
fileLines (Extension -> [RelPosixLink]) -> IO Extension -> IO [RelPosixLink]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Extension
getFiles
  (RelPosixLink -> IO (RelPosixLink, a))
-> [RelPosixLink] -> IO [(RelPosixLink, a)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse RelPosixLink -> IO (RelPosixLink, a)
scanFile ([RelPosixLink] -> IO [(RelPosixLink, a)])
-> [RelPosixLink] -> IO [(RelPosixLink, a)]
forall a b. (a -> b) -> a -> b
$ (RelPosixLink -> Bool) -> [RelPosixLink] -> [RelPosixLink]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (RelPosixLink -> Bool) -> RelPosixLink -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelPosixLink -> Bool
isIgnored) [RelPosixLink]
relativeFiles

  where

    getFiles :: IO Extension
getFiles = case ReadDirectoryMode
mode of
      ReadDirectoryMode
RdmTracked -> IO Extension
getTrackedFiles
      ReadDirectoryMode
RdmUntracked -> IO Extension
getUntrackedFiles
      ReadDirectoryMode
RdmBothTrackedAndUtracked -> (Extension -> ShowS)
-> IO Extension -> IO Extension -> IO Extension
forall a b c. (a -> b -> c) -> IO a -> IO b -> IO c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Extension -> ShowS
forall a. Semigroup a => a -> a -> a
(<>) IO Extension
getTrackedFiles IO Extension
getUntrackedFiles

    getTrackedFiles :: IO Extension
getTrackedFiles = CreateProcess -> Extension -> IO Extension
readCreateProcess
      (Extension -> CreateProcess
shell Extension
"git ls-files -z"){cwd = Just root} Extension
""
    getUntrackedFiles :: IO Extension
getUntrackedFiles = CreateProcess -> Extension -> IO Extension
readCreateProcess
      (Extension -> CreateProcess
shell Extension
"git ls-files -z --others --exclude-standard"){cwd = Just root} Extension
""

    fileLines :: String -> [String]
    fileLines :: Extension -> [Extension]
fileLines ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\0') -> Extension
ls) =
      case (Char -> Bool) -> Extension -> (Extension, Extension)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\0') Extension
ls of
        ([], Extension
_) -> []
        (Extension
f, Extension
ls') -> Extension
f Extension -> [Extension] -> [Extension]
forall a. a -> [a] -> [a]
: Extension -> [Extension]
fileLines Extension
ls'

    scanFile :: RelPosixLink -> IO (RelPosixLink, a)
    scanFile :: RelPosixLink -> IO (RelPosixLink, a)
scanFile RelPosixLink
c = (RelPosixLink
c,) (a -> (RelPosixLink, a)) -> IO a -> IO (RelPosixLink, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RelPosixLink -> IO a
scanner RelPosixLink
c

    isIgnored :: RelPosixLink -> Bool
    isIgnored :: RelPosixLink -> Bool
isIgnored = [CanonicalRelGlobPattern] -> CanonicalRelPosixLink -> Bool
matchesGlobPatterns (ExclusionConfig -> Field Identity [CanonicalRelGlobPattern]
forall (f :: * -> *).
ExclusionConfig' f -> Field f [CanonicalRelGlobPattern]
ecIgnore ExclusionConfig
config) (CanonicalRelPosixLink -> Bool)
-> (RelPosixLink -> CanonicalRelPosixLink) -> RelPosixLink -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelPosixLink -> CanonicalRelPosixLink
canonicalizeRelPosixLink

scanRepo
  :: MonadIO m
  => ScanPolicy
  -> Rewrite
  -> FileSupport
  -> ExclusionConfig
  -> FilePath
  -> m ScanResult
scanRepo :: forall (m :: * -> *).
MonadIO m =>
ScanPolicy
-> Rewrite
-> FileSupport
-> ExclusionConfig
-> Extension
-> m ScanResult
scanRepo ScanPolicy
scanMode Rewrite
rw FileSupport
formatsSupport ExclusionConfig
config Extension
root = do
  Rewrite -> Text -> m ()
forall (m :: * -> *). MonadIO m => Rewrite -> Text -> m ()
putTextRewrite Rewrite
rw Text
"Scanning repository..."

  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Extension -> IO Bool
doesDirectoryExist Extension
root) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Extension -> IO ()
forall (m :: * -> *) a. MonadIO m => Extension -> m a
die (Extension -> IO ()) -> Extension -> IO ()
forall a b. (a -> b) -> a -> b
$ Extension
"Repository's root does not seem to be a directory: " Extension -> ShowS
forall a. Semigroup a => a -> a -> a
<> Extension
root

  ([ScanError 'Gather]
errs, [(RelPosixLink, FileStatus)]
processedFiles) <-
    let mode :: ReadDirectoryMode
mode = case ScanPolicy
scanMode of
          ScanPolicy
OnlyTracked -> ReadDirectoryMode
RdmTracked
          ScanPolicy
IncludeUntracked -> ReadDirectoryMode
RdmBothTrackedAndUtracked
    in  IO ([ScanError 'Gather], [(RelPosixLink, FileStatus)])
-> m ([ScanError 'Gather], [(RelPosixLink, FileStatus)])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([ScanError 'Gather], [(RelPosixLink, FileStatus)])
 -> m ([ScanError 'Gather], [(RelPosixLink, FileStatus)]))
-> IO ([ScanError 'Gather], [(RelPosixLink, FileStatus)])
-> m ([ScanError 'Gather], [(RelPosixLink, FileStatus)])
forall a b. (a -> b) -> a -> b
$ ([(RelPosixLink, (FileStatus, [ScanError 'Parse]))]
-> [ScanError 'Gather]
gatherScanErrs ([(RelPosixLink, (FileStatus, [ScanError 'Parse]))]
 -> [ScanError 'Gather])
-> ([(RelPosixLink, (FileStatus, [ScanError 'Parse]))]
    -> [(RelPosixLink, FileStatus)])
-> [(RelPosixLink, (FileStatus, [ScanError 'Parse]))]
-> ([ScanError 'Gather], [(RelPosixLink, FileStatus)])
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [(RelPosixLink, (FileStatus, [ScanError 'Parse]))]
-> [(RelPosixLink, FileStatus)]
gatherFileStatuses)
          ([(RelPosixLink, (FileStatus, [ScanError 'Parse]))]
 -> ([ScanError 'Gather], [(RelPosixLink, FileStatus)]))
-> IO [(RelPosixLink, (FileStatus, [ScanError 'Parse]))]
-> IO ([ScanError 'Gather], [(RelPosixLink, FileStatus)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadDirectoryMode
-> ExclusionConfig
-> (RelPosixLink -> IO (FileStatus, [ScanError 'Parse]))
-> Extension
-> IO [(RelPosixLink, (FileStatus, [ScanError 'Parse]))]
forall a.
ReadDirectoryMode
-> ExclusionConfig
-> (RelPosixLink -> IO a)
-> Extension
-> IO [(RelPosixLink, a)]
readDirectoryWith ReadDirectoryMode
mode ExclusionConfig
config RelPosixLink -> IO (FileStatus, [ScanError 'Parse])
processFile Extension
root

  [(RelPosixLink, FileStatus)]
notProcessedFiles <- case ScanPolicy
scanMode of
    ScanPolicy
OnlyTracked -> IO [(RelPosixLink, FileStatus)] -> m [(RelPosixLink, FileStatus)]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(RelPosixLink, FileStatus)] -> m [(RelPosixLink, FileStatus)])
-> IO [(RelPosixLink, FileStatus)]
-> m [(RelPosixLink, FileStatus)]
forall a b. (a -> b) -> a -> b
$
      ReadDirectoryMode
-> ExclusionConfig
-> (RelPosixLink -> IO FileStatus)
-> Extension
-> IO [(RelPosixLink, FileStatus)]
forall a.
ReadDirectoryMode
-> ExclusionConfig
-> (RelPosixLink -> IO a)
-> Extension
-> IO [(RelPosixLink, a)]
readDirectoryWith ReadDirectoryMode
RdmUntracked ExclusionConfig
config (IO FileStatus -> RelPosixLink -> IO FileStatus
forall a b. a -> b -> a
const (IO FileStatus -> RelPosixLink -> IO FileStatus)
-> IO FileStatus -> RelPosixLink -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ FileStatus -> IO FileStatus
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileStatus
NotAddedToGit) Extension
root
    ScanPolicy
IncludeUntracked -> [(RelPosixLink, FileStatus)] -> m [(RelPosixLink, FileStatus)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

  [(RelPosixLink, FileStatus)]
scannableNotProcessedFiles <- IO [(RelPosixLink, FileStatus)] -> m [(RelPosixLink, FileStatus)]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(RelPosixLink, FileStatus)] -> m [(RelPosixLink, FileStatus)])
-> IO [(RelPosixLink, FileStatus)]
-> m [(RelPosixLink, FileStatus)]
forall a b. (a -> b) -> a -> b
$
    ((RelPosixLink, FileStatus) -> IO Bool)
-> [(RelPosixLink, FileStatus)] -> IO [(RelPosixLink, FileStatus)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Maybe ScanAction -> Bool) -> IO (Maybe ScanAction) -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe ScanAction -> Bool
forall a. Maybe a -> Bool
isJust (IO (Maybe ScanAction) -> IO Bool)
-> ((RelPosixLink, FileStatus) -> IO (Maybe ScanAction))
-> (RelPosixLink, FileStatus)
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelPosixLink -> IO (Maybe ScanAction)
fileScanner (RelPosixLink -> IO (Maybe ScanAction))
-> ((RelPosixLink, FileStatus) -> RelPosixLink)
-> (RelPosixLink, FileStatus)
-> IO (Maybe ScanAction)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RelPosixLink, FileStatus) -> RelPosixLink
forall a b. (a, b) -> a
fst) [(RelPosixLink, FileStatus)]
notProcessedFiles

  Maybe (NonEmpty RelPosixLink)
-> (NonEmpty RelPosixLink -> m ()) -> m ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust ([RelPosixLink] -> Maybe (NonEmpty RelPosixLink)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([RelPosixLink] -> Maybe (NonEmpty RelPosixLink))
-> [RelPosixLink] -> Maybe (NonEmpty RelPosixLink)
forall a b. (a -> b) -> a -> b
$ ((RelPosixLink, FileStatus) -> RelPosixLink)
-> [(RelPosixLink, FileStatus)] -> [RelPosixLink]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (RelPosixLink, FileStatus) -> RelPosixLink
forall a b. (a, b) -> a
fst [(RelPosixLink, FileStatus)]
scannableNotProcessedFiles) ((NonEmpty RelPosixLink -> m ()) -> m ())
-> (NonEmpty RelPosixLink -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty RelPosixLink
files -> forall a (m :: * -> *). (Print a, MonadIO m) => Handle -> a -> m ()
hPutStrLn @Text Handle
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 :: [RelPosixLink]
trackedDirs = (Element [(RelPosixLink, FileStatus)] -> [RelPosixLink])
-> [(RelPosixLink, FileStatus)] -> [RelPosixLink]
forall m.
Monoid m =>
(Element [(RelPosixLink, FileStatus)] -> m)
-> [(RelPosixLink, FileStatus)] -> m
forall t m. (Container t, Monoid m) => (Element t -> m) -> t -> m
foldMap (RelPosixLink -> [RelPosixLink]
getIntermediateDirs (RelPosixLink -> [RelPosixLink])
-> ((RelPosixLink, FileStatus) -> RelPosixLink)
-> (RelPosixLink, FileStatus)
-> [RelPosixLink]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RelPosixLink, FileStatus) -> RelPosixLink
forall a b. (a, b) -> a
fst) [(RelPosixLink, FileStatus)]
processedFiles
      untrackedDirs :: [RelPosixLink]
untrackedDirs = (Element [(RelPosixLink, FileStatus)] -> [RelPosixLink])
-> [(RelPosixLink, FileStatus)] -> [RelPosixLink]
forall m.
Monoid m =>
(Element [(RelPosixLink, FileStatus)] -> m)
-> [(RelPosixLink, FileStatus)] -> m
forall t m. (Container t, Monoid m) => (Element t -> m) -> t -> m
foldMap (RelPosixLink -> [RelPosixLink]
getIntermediateDirs (RelPosixLink -> [RelPosixLink])
-> ((RelPosixLink, FileStatus) -> RelPosixLink)
-> (RelPosixLink, FileStatus)
-> [RelPosixLink]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RelPosixLink, FileStatus) -> RelPosixLink
forall a b. (a, b) -> a
fst) [(RelPosixLink, FileStatus)]
notProcessedFiles

  ScanResult -> m ScanResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScanResult -> m ScanResult)
-> (RepoInfo -> ScanResult) -> RepoInfo -> m ScanResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ScanError 'Gather] -> RepoInfo -> ScanResult
ScanResult [ScanError 'Gather]
errs (RepoInfo -> m ScanResult) -> RepoInfo -> m ScanResult
forall a b. (a -> b) -> a -> b
$ RepoInfo
    { riFiles :: Map CanonicalRelPosixLink (RelPosixLink, FileStatus)
riFiles = [(CanonicalRelPosixLink, (RelPosixLink, FileStatus))]
-> Map CanonicalRelPosixLink (RelPosixLink, FileStatus)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(CanonicalRelPosixLink, (RelPosixLink, FileStatus))]
 -> Map CanonicalRelPosixLink (RelPosixLink, FileStatus))
-> [(CanonicalRelPosixLink, (RelPosixLink, FileStatus))]
-> Map CanonicalRelPosixLink (RelPosixLink, FileStatus)
forall a b. (a -> b) -> a -> b
$ ((RelPosixLink, FileStatus)
 -> (CanonicalRelPosixLink, (RelPosixLink, FileStatus)))
-> [(RelPosixLink, FileStatus)]
-> [(CanonicalRelPosixLink, (RelPosixLink, FileStatus))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RelPosixLink, FileStatus)
-> (CanonicalRelPosixLink, (RelPosixLink, FileStatus))
forall a.
(RelPosixLink, a) -> (CanonicalRelPosixLink, (RelPosixLink, a))
canonicalLinkEntry ([(RelPosixLink, FileStatus)]
 -> [(CanonicalRelPosixLink, (RelPosixLink, FileStatus))])
-> [(RelPosixLink, FileStatus)]
-> [(CanonicalRelPosixLink, (RelPosixLink, FileStatus))]
forall a b. (a -> b) -> a -> b
$ [(RelPosixLink, FileStatus)]
processedFiles [(RelPosixLink, FileStatus)]
-> [(RelPosixLink, FileStatus)] -> [(RelPosixLink, FileStatus)]
forall a. Semigroup a => a -> a -> a
<> [(RelPosixLink, FileStatus)]
notProcessedFiles
    , riDirectories :: Map CanonicalRelPosixLink (RelPosixLink, DirectoryStatus)
riDirectories = [(CanonicalRelPosixLink, (RelPosixLink, DirectoryStatus))]
-> Map CanonicalRelPosixLink (RelPosixLink, DirectoryStatus)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(CanonicalRelPosixLink, (RelPosixLink, DirectoryStatus))]
 -> Map CanonicalRelPosixLink (RelPosixLink, DirectoryStatus))
-> [(CanonicalRelPosixLink, (RelPosixLink, DirectoryStatus))]
-> Map CanonicalRelPosixLink (RelPosixLink, DirectoryStatus)
forall a b. (a -> b) -> a -> b
$ ((RelPosixLink, DirectoryStatus)
 -> (CanonicalRelPosixLink, (RelPosixLink, DirectoryStatus)))
-> [(RelPosixLink, DirectoryStatus)]
-> [(CanonicalRelPosixLink, (RelPosixLink, DirectoryStatus))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RelPosixLink, DirectoryStatus)
-> (CanonicalRelPosixLink, (RelPosixLink, DirectoryStatus))
forall a.
(RelPosixLink, a) -> (CanonicalRelPosixLink, (RelPosixLink, a))
canonicalLinkEntry ((RelPosixLink -> (RelPosixLink, DirectoryStatus))
-> [RelPosixLink] -> [(RelPosixLink, DirectoryStatus)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, DirectoryStatus
TrackedDirectory) [RelPosixLink]
trackedDirs
        [(RelPosixLink, DirectoryStatus)]
-> [(RelPosixLink, DirectoryStatus)]
-> [(RelPosixLink, DirectoryStatus)]
forall a. Semigroup a => a -> a -> a
<> (RelPosixLink -> (RelPosixLink, DirectoryStatus))
-> [RelPosixLink] -> [(RelPosixLink, DirectoryStatus)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, DirectoryStatus
UntrackedDirectory) [RelPosixLink]
untrackedDirs)
    }
  where
    fileScanner :: RelPosixLink -> IO (Maybe ScanAction)
    fileScanner :: RelPosixLink -> IO (Maybe ScanAction)
fileScanner RelPosixLink
file = do
      Bool
isSymlink <- Extension -> IO Bool
pathIsSymbolicLink (Extension -> RelPosixLink -> Extension
filePathFromRoot Extension
root RelPosixLink
file)
      Maybe ScanAction -> IO (Maybe ScanAction)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ScanAction -> IO (Maybe ScanAction))
-> Maybe ScanAction -> IO (Maybe ScanAction)
forall a b. (a -> b) -> a -> b
$ FileSupport
formatsSupport Bool
isSymlink (Extension -> Maybe ScanAction) -> Extension -> Maybe ScanAction
forall a b. (a -> b) -> a -> b
$ RelPosixLink -> Extension
takeExtension RelPosixLink
file

    gatherScanErrs
      :: [(RelPosixLink, (FileStatus, [ScanError 'Parse]))]
      -> [ScanError 'Gather]
    gatherScanErrs :: [(RelPosixLink, (FileStatus, [ScanError 'Parse]))]
-> [ScanError 'Gather]
gatherScanErrs = (Element [(RelPosixLink, (FileStatus, [ScanError 'Parse]))]
 -> [ScanError 'Gather])
-> [(RelPosixLink, (FileStatus, [ScanError 'Parse]))]
-> [ScanError 'Gather]
forall m.
Monoid m =>
(Element [(RelPosixLink, (FileStatus, [ScanError 'Parse]))] -> m)
-> [(RelPosixLink, (FileStatus, [ScanError 'Parse]))] -> m
forall t m. (Container t, Monoid m) => (Element t -> m) -> t -> m
foldMap ((Element [(RelPosixLink, (FileStatus, [ScanError 'Parse]))]
  -> [ScanError 'Gather])
 -> [(RelPosixLink, (FileStatus, [ScanError 'Parse]))]
 -> [ScanError 'Gather])
-> (Element [(RelPosixLink, (FileStatus, [ScanError 'Parse]))]
    -> [ScanError 'Gather])
-> [(RelPosixLink, (FileStatus, [ScanError 'Parse]))]
-> [ScanError 'Gather]
forall a b. (a -> b) -> a -> b
$ \(RelPosixLink
file, (FileStatus
_, [ScanError 'Parse]
errs)) ->
      RelPosixLink -> ScanError 'Parse -> ScanError 'Gather
mkGatherScanError RelPosixLink
file (ScanError 'Parse -> ScanError 'Gather)
-> [ScanError 'Parse] -> [ScanError 'Gather]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ScanError 'Parse]
errs

    gatherFileStatuses
      :: [(RelPosixLink, (FileStatus, [ScanError 'Parse]))]
      -> [(RelPosixLink, FileStatus)]
    gatherFileStatuses :: [(RelPosixLink, (FileStatus, [ScanError 'Parse]))]
-> [(RelPosixLink, FileStatus)]
gatherFileStatuses = ((RelPosixLink, (FileStatus, [ScanError 'Parse]))
 -> (RelPosixLink, FileStatus))
-> [(RelPosixLink, (FileStatus, [ScanError 'Parse]))]
-> [(RelPosixLink, FileStatus)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (((FileStatus, [ScanError 'Parse]) -> FileStatus)
-> (RelPosixLink, (FileStatus, [ScanError 'Parse]))
-> (RelPosixLink, FileStatus)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (FileStatus, [ScanError 'Parse]) -> FileStatus
forall a b. (a, b) -> a
fst)

    processFile :: RelPosixLink -> IO (FileStatus, [ScanError 'Parse])
    processFile :: RelPosixLink -> IO (FileStatus, [ScanError 'Parse])
processFile RelPosixLink
file = do
      Maybe ScanAction
mScanner <- RelPosixLink -> IO (Maybe ScanAction)
fileScanner RelPosixLink
file
      case Maybe ScanAction
mScanner of
        Maybe ScanAction
Nothing -> (FileStatus, [ScanError 'Parse])
-> IO (FileStatus, [ScanError 'Parse])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileStatus
NotScannable, [])
        Just ScanAction
scanner -> ScanAction
scanner Extension
root RelPosixLink
file IO (FileInfo, [ScanError 'Parse])
-> ((FileInfo, [ScanError 'Parse])
    -> (FileStatus, [ScanError 'Parse]))
-> IO (FileStatus, [ScanError 'Parse])
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (FileInfo -> Identity FileStatus)
-> (FileInfo, [ScanError 'Parse])
-> Identity (FileStatus, [ScanError 'Parse])
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  (FileInfo, [ScanError 'Parse])
  (FileStatus, [ScanError 'Parse])
  FileInfo
  FileStatus
_1 ((FileInfo -> Identity FileStatus)
 -> (FileInfo, [ScanError 'Parse])
 -> Identity (FileStatus, [ScanError 'Parse]))
-> (FileInfo -> FileStatus)
-> (FileInfo, [ScanError 'Parse])
-> (FileStatus, [ScanError 'Parse])
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ FileInfo -> FileStatus
Scanned

    canonicalLinkEntry
      :: (RelPosixLink, a)
      -> (CanonicalRelPosixLink, (RelPosixLink, a))
    canonicalLinkEntry :: forall a.
(RelPosixLink, a) -> (CanonicalRelPosixLink, (RelPosixLink, a))
canonicalLinkEntry (RelPosixLink
a, a
b) = (RelPosixLink -> CanonicalRelPosixLink
canonicalizeRelPosixLink RelPosixLink
a, (RelPosixLink
a, a
b))

-----------------------------------------------------------
-- Yaml instances
-----------------------------------------------------------

instance FromJSON Regex where
  parseJSON :: Value -> Parser Regex
parseJSON = Extension -> (Text -> Parser Regex) -> Value -> Parser Regex
forall a. Extension -> (Text -> Parser a) -> Value -> Parser a
withText Extension
"regex" ((Text -> Parser Regex) -> Value -> Parser Regex)
-> (Text -> Parser Regex) -> Value -> Parser Regex
forall a b. (a -> b) -> a -> b
$ \Text
val -> do
    let errOrRegex :: Either Extension Regex
errOrRegex = CompOption -> ExecOption -> Text -> Either Extension Regex
R.compile CompOption
defaultCompOption ExecOption
defaultExecOption Text
val
    (Extension -> Parser Regex)
-> (Regex -> Parser Regex)
-> Either Extension Regex
-> Parser Regex
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Parser Regex
forall a. HasCallStack => Text -> a
error (Text -> Parser Regex)
-> (Extension -> Text) -> Extension -> Parser Regex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Extension -> Text
forall b a. (Show a, IsString b) => a -> b
show) Regex -> Parser Regex
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Either Extension Regex
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
defaultCompOption = CompOption
  { caseSensitive :: Bool
caseSensitive = Bool
True
  , multiline :: Bool
multiline = Bool
True
  , rightAssoc :: Bool
rightAssoc = Bool
True
  , newSyntax :: Bool
newSyntax = Bool
True
  , lastStarGreedy :: Bool
lastStarGreedy = Bool
False
  }

-- ExecOption value to improve speed
defaultExecOption :: ExecOption
defaultExecOption :: ExecOption
defaultExecOption = ExecOption {captureGroups :: Bool
captureGroups = Bool
False}

instance FromJSON (ExclusionConfig' Maybe) where
  parseJSON :: Value -> Parser (ExclusionConfig' Maybe)
parseJSON = Options -> Value -> Parser (ExclusionConfig' Maybe)
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
aesonConfigOption

instance FromJSON (ExclusionConfig) where
  parseJSON :: Value -> Parser ExclusionConfig
parseJSON = Options -> Value -> Parser ExclusionConfig
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
aesonConfigOption