{- SPDX-FileCopyrightText: 2021 Serokell <https://serokell.io>
 -
 - SPDX-License-Identifier: MPL-2.0
 -}

module Xrefcheck.Command
  ( defaultAction
  ) where

import Universum

import Data.Reflection (Given, give)
import Data.Yaml (decodeFileEither, prettyPrintParseException)
import Fmt (build, fmt, fmtLn)
import System.Console.Pretty (supportsPretty)
import System.Directory (doesFileExist)
import Text.Interpolation.Nyan

import Xrefcheck.CLI (Options (..), addExclusionOptions, addNetworkingOptions, defaultConfigPaths)
import Xrefcheck.Config
  (Config, Config' (..), ScannersConfig, ScannersConfig' (..), defConfig, overrideConfig)
import Xrefcheck.Core (Flavor (..))
import Xrefcheck.Progress (allowRewrite)
import Xrefcheck.Scan
import Xrefcheck.Scanners.Markdown (markdownSupport)
import Xrefcheck.Scanners.Symlink (symlinkSupport)
import Xrefcheck.System (PrintUnixPaths (..), askWithinCI)
import Xrefcheck.Util
import Xrefcheck.Verify (reportVerifyErrs, verifyErrors, verifyRepo)

readConfig :: FilePath -> IO Config
readConfig :: String -> IO Config
readConfig String
path = (ConfigOptional -> Config) -> IO ConfigOptional -> IO Config
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConfigOptional -> Config
overrideConfig do
  String -> IO (Either ParseException ConfigOptional)
forall a. FromJSON a => String -> IO (Either ParseException a)
decodeFileEither String
path
    IO (Either ParseException ConfigOptional)
-> (Either ParseException ConfigOptional -> IO ConfigOptional)
-> IO ConfigOptional
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ParseException -> IO ConfigOptional)
-> (ConfigOptional -> IO ConfigOptional)
-> Either ParseException ConfigOptional
-> IO ConfigOptional
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> IO ConfigOptional
forall a. HasCallStack => Text -> a
error (Text -> IO ConfigOptional)
-> (ParseException -> Text) -> ParseException -> IO ConfigOptional
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText (String -> Text)
-> (ParseException -> String) -> ParseException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseException -> String
prettyPrintParseException) ConfigOptional -> IO ConfigOptional
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

configuredFileSupport :: Given PrintUnixPaths => ScannersConfig -> FileSupport
configuredFileSupport :: Given PrintUnixPaths => ScannersConfig -> FileSupport
configuredFileSupport ScannersConfig{Field Identity Double
MarkdownConfig
scMarkdown :: MarkdownConfig
scAnchorSimilarityThreshold :: Field Identity Double
scMarkdown :: forall (f :: * -> *). ScannersConfig' f -> MarkdownConfig
scAnchorSimilarityThreshold :: forall (f :: * -> *). ScannersConfig' f -> Field f Double
..} = [FileSupport] -> FileSupport
firstFileSupport
    [ Given PrintUnixPaths => MarkdownConfig -> FileSupport
MarkdownConfig -> FileSupport
markdownSupport MarkdownConfig
scMarkdown
    , FileSupport
Given PrintUnixPaths => FileSupport
symlinkSupport
    ]

findFirstExistingFile :: [FilePath] -> IO (Maybe FilePath)
findFirstExistingFile :: [String] -> IO (Maybe String)
findFirstExistingFile = \case
  [] -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
  (String
file : [String]
files) -> do
    Bool
exists <- String -> IO Bool
doesFileExist String
file
    if Bool
exists then Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String
forall a. a -> Maybe a
Just String
file) else [String] -> IO (Maybe String)
findFirstExistingFile [String]
files

defaultAction :: Options -> IO ()
defaultAction :: Options -> IO ()
defaultAction Options{Bool
String
Maybe Bool
Maybe String
Maybe ColorMode
PrintUnixPaths
VerifyMode
ScanPolicy
NetworkingOptions
ExclusionOptions
oConfigPath :: Maybe String
oRoot :: String
oMode :: VerifyMode
oVerbose :: Bool
oShowProgressBar :: Maybe Bool
oColorMode :: Maybe ColorMode
oPrintUnixPaths :: PrintUnixPaths
oExclusionOptions :: ExclusionOptions
oNetworkingOptions :: NetworkingOptions
oScanPolicy :: ScanPolicy
oConfigPath :: Options -> Maybe String
oRoot :: Options -> String
oMode :: Options -> VerifyMode
oVerbose :: Options -> Bool
oShowProgressBar :: Options -> Maybe Bool
oColorMode :: Options -> Maybe ColorMode
oPrintUnixPaths :: Options -> PrintUnixPaths
oExclusionOptions :: Options -> ExclusionOptions
oNetworkingOptions :: Options -> NetworkingOptions
oScanPolicy :: Options -> ScanPolicy
..} = do
  Bool
withinCI <- IO Bool
askWithinCI
  Bool
coloringSupported <- IO Bool
supportsPretty
  let colorMode :: ColorMode
colorMode = Maybe ColorMode
oColorMode Maybe ColorMode -> ColorMode -> ColorMode
forall a. Maybe a -> a -> a
?:
        if Bool
withinCI Bool -> Bool -> Bool
|| Bool
coloringSupported
        then ColorMode
WithColors
        else ColorMode
WithoutColors

  PrintUnixPaths -> (Given PrintUnixPaths => IO ()) -> IO ()
forall a r. a -> (Given a => r) -> r
give PrintUnixPaths
oPrintUnixPaths ((Given PrintUnixPaths => IO ()) -> IO ())
-> (Given PrintUnixPaths => IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ ColorMode -> (Given ColorMode => IO ()) -> IO ()
forall a r. a -> (Given a => r) -> r
give ColorMode
colorMode ((Given ColorMode => IO ()) -> IO ())
-> (Given ColorMode => IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Config
config <- case Maybe String
oConfigPath of
      Just String
configPath -> String -> IO Config
readConfig String
configPath
      Maybe String
Nothing -> do
        Maybe String
mConfigPath <- [String] -> IO (Maybe String)
findFirstExistingFile [String]
defaultConfigPaths
        case Maybe String
mConfigPath of
          Just String
configPath -> String -> IO Config
readConfig String
configPath
          Maybe String
Nothing -> do
            forall a (m :: * -> *). (Print a, MonadIO m) => Handle -> a -> m ()
hPutStrLn @Text Handle
stderr
              [int||
              Configuration file not found, using default config \
              for GitHub repositories
              |]
            Config -> IO Config
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Config -> IO Config) -> Config -> IO Config
forall a b. (a -> b) -> a -> b
$ HasCallStack => Flavor -> Config
Flavor -> Config
defConfig Flavor
GitHub

    let showProgressBar :: Bool
showProgressBar = Maybe Bool
oShowProgressBar Maybe Bool -> Bool -> Bool
forall a. Maybe a -> a -> a
?: Bool -> Bool
not Bool
withinCI

    (ScanResult [ScanError 'Gather]
scanErrs RepoInfo
repoInfo) <- Bool -> (Rewrite -> IO ScanResult) -> IO ScanResult
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Bool -> (Rewrite -> m a) -> m a
allowRewrite Bool
showProgressBar ((Rewrite -> IO ScanResult) -> IO ScanResult)
-> (Rewrite -> IO ScanResult) -> IO ScanResult
forall a b. (a -> b) -> a -> b
$ \Rewrite
rw -> do
      let fullConfig :: ExclusionConfig
fullConfig = ExclusionConfig -> ExclusionOptions -> ExclusionConfig
addExclusionOptions (Config -> Field Identity ExclusionConfig
forall (f :: * -> *). Config' f -> Field f (ExclusionConfig' f)
cExclusions Config
config) ExclusionOptions
oExclusionOptions
          fileSupport :: FileSupport
fileSupport = Given PrintUnixPaths => ScannersConfig -> FileSupport
ScannersConfig -> FileSupport
configuredFileSupport (ScannersConfig -> FileSupport) -> ScannersConfig -> FileSupport
forall a b. (a -> b) -> a -> b
$ Config -> ScannersConfig
forall (f :: * -> *). Config' f -> ScannersConfig' f
cScanners Config
config
      ScanPolicy
-> Rewrite
-> FileSupport
-> ExclusionConfig
-> String
-> IO ScanResult
forall (m :: * -> *).
MonadIO m =>
ScanPolicy
-> Rewrite
-> FileSupport
-> ExclusionConfig
-> String
-> m ScanResult
scanRepo ScanPolicy
oScanPolicy Rewrite
rw FileSupport
fileSupport ExclusionConfig
fullConfig String
oRoot

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
oVerbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Builder -> IO ()
forall b. FromBuilder b => Builder -> b
fmt [int||
      === Repository data ===

      #{interpolateIndentF 2 (build repoInfo)}
      |]

    Maybe (NonEmpty (ScanError 'Gather))
-> (NonEmpty (ScanError 'Gather) -> IO ()) -> IO ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust ([ScanError 'Gather] -> Maybe (NonEmpty (ScanError 'Gather))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([ScanError 'Gather] -> Maybe (NonEmpty (ScanError 'Gather)))
-> [ScanError 'Gather] -> Maybe (NonEmpty (ScanError 'Gather))
forall a b. (a -> b) -> a -> b
$ (ScanError 'Gather -> ScanError 'Gather -> Ordering)
-> [ScanError 'Gather] -> [ScanError 'Gather]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (RelPosixLink -> RelPosixLink -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (RelPosixLink -> RelPosixLink -> Ordering)
-> (ScanError 'Gather -> RelPosixLink)
-> ScanError 'Gather
-> ScanError 'Gather
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ScanError 'Gather -> RelPosixLink
ScanError 'Gather -> ScanStageFile 'Gather
forall (a :: ScanStage). ScanError a -> ScanStageFile a
seFile) [ScanError 'Gather]
scanErrs) NonEmpty (ScanError 'Gather) -> IO ()
Given ColorMode => NonEmpty (ScanError 'Gather) -> IO ()
reportScanErrs

    VerifyResult $ WithReferenceLoc VerifyError
verifyRes <- Bool
-> (Rewrite -> IO (VerifyResult $ WithReferenceLoc VerifyError))
-> IO (VerifyResult $ WithReferenceLoc VerifyError)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Bool -> (Rewrite -> m a) -> m a
allowRewrite Bool
showProgressBar ((Rewrite -> IO (VerifyResult $ WithReferenceLoc VerifyError))
 -> IO (VerifyResult $ WithReferenceLoc VerifyError))
-> (Rewrite -> IO (VerifyResult $ WithReferenceLoc VerifyError))
-> IO (VerifyResult $ WithReferenceLoc VerifyError)
forall a b. (a -> b) -> a -> b
$ \Rewrite
rw -> do
      let fullConfig :: Config
fullConfig = Config
config
            { cNetworking = addNetworkingOptions (cNetworking config) oNetworkingOptions }
      Given ColorMode =>
Rewrite
-> Config
-> VerifyMode
-> RepoInfo
-> IO (VerifyResult $ WithReferenceLoc VerifyError)
Rewrite
-> Config
-> VerifyMode
-> RepoInfo
-> IO (VerifyResult $ WithReferenceLoc VerifyError)
verifyRepo Rewrite
rw Config
fullConfig VerifyMode
oMode RepoInfo
repoInfo

    case (VerifyResult $ WithReferenceLoc VerifyError)
-> Maybe (NonEmpty (WithReferenceLoc VerifyError))
forall e. VerifyResult e -> Maybe (NonEmpty e)
verifyErrors VerifyResult $ WithReferenceLoc VerifyError
verifyRes of
      Maybe (NonEmpty (WithReferenceLoc VerifyError))
Nothing | [ScanError 'Gather] -> Bool
forall t. Container t => t -> Bool
null [ScanError 'Gather]
scanErrs ->
        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
Green Builder
"All repository links are valid."
      Maybe (NonEmpty (WithReferenceLoc VerifyError))
Nothing -> IO ()
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
      Just NonEmpty (WithReferenceLoc VerifyError)
verifyErrs -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ScanError 'Gather] -> Bool
forall t. Container t => t -> Bool
null [ScanError 'Gather]
scanErrs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Builder -> IO ()
forall b. FromBuilder b => Builder -> b
fmt Builder
"\n"
        NonEmpty (WithReferenceLoc VerifyError) -> IO ()
Given ColorMode => NonEmpty (WithReferenceLoc VerifyError) -> IO ()
reportVerifyErrs NonEmpty (WithReferenceLoc VerifyError)
verifyErrs
        IO ()
forall (m :: * -> *) a. MonadIO m => m a
exitFailure