content: {- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>
   -
   - SPDX-License-Identifier: MPL-2.0
   -}
  
  module Xrefcheck.System
    ( askWithinCI
  
    , RelPosixLink (..)
    , (</>)
    , mkRelPosixLink
    , filePathFromRoot
    , getIntermediateDirs
    , hasBackslash
    , takeDirectory
    , takeExtension
  
    , CanonicalRelPosixLink (unCanonicalRelPosixLink)
    , hasUnexpanededParentIndirections
    , canonicalizeRelPosixLink
  
    , CanonicalRelGlobPattern (unCanonicalRelGlobPattern)
    , matchesGlobPatterns
    , mkCanonicalRelGlobPattern
  
    , PrintUnixPaths(..)
    , mkPathForPrinting
    ) where
  
  import Universum
  
  import Data.Aeson (FromJSON (..), withText)
  import Data.Char qualified as C
  import Data.Reflection (Given (..))
  import Data.Text qualified as T
  import Fmt (Buildable)
  import System.Console.Pretty (Pretty)
  import System.Environment (lookupEnv)
  import System.FilePath qualified as FP
  import System.FilePath.Glob qualified as Glob
  import System.FilePath.Posix qualified as FPP
  import Text.Interpolation.Nyan (int, rmode')
  
  -- | Heuristics to check whether we are running within CI.
  -- Check the respective env variable which is usually set in all CIs.
  askWithinCI :: IO Bool
  askWithinCI = lookupEnv "CI" <&> \case
    Just "1" -> True
    Just (map C.toLower -> "true") -> True
    _ -> False
  
  -- | Relative file path with POSIX path separators.
  --
  -- This type exist in contrast to 'FilePath' which, in this project,
  -- is used for platform-dependent file paths and related filesystem
  -- IO operations.
  --
  -- Note that `RelPosixLink` may contain `\` characters, but they are
  -- considered as part of the filename instead of denoting a path
  -- separator.
  newtype RelPosixLink = RelPosixLink
    { unRelPosixLink :: Text
    } deriving newtype (Show, Eq, Ord, NFData, Buildable, Pretty)
  
  -- | Create a POSIX file path from a platform-dependent one.
  mkRelPosixLink :: FilePath -> RelPosixLink
  mkRelPosixLink = RelPosixLink
    . withPathSeparator FPP.pathSeparator
    . fromString
  
  -- | Join two 'RelPosixLink's.
  (</>) :: RelPosixLink -> RelPosixLink -> RelPosixLink
  RelPosixLink a </> RelPosixLink b =
    let a' = fromMaybe a $ T.stripSuffix "/" a
        b' = fromMaybe b $ T.stripPrefix "./" a
    in case (a', b') of
          ("", _) -> RelPosixLink b
          (".", _) -> RelPosixLink b
          _ -> RelPosixLink $ a' <> "/" <> b'
  
  -- Get the platform-dependent file path from a 'RelPosixLink'
  -- considered as relative to another given platform-dependent
  -- 'FilePath'.
  --
  -- In Windows, every `\` occurrence will be replaced by `/`.
  filePathFromRoot :: FilePath -> RelPosixLink -> FilePath
  filePathFromRoot rootPath = (rootPath FP.</>)
    . toString
    . withPathSeparator FP.pathSeparator
    . unRelPosixLink
  
  -- | 'FilePath.takeDirectory' version for 'RelPosixLink'.
  takeDirectory :: RelPosixLink -> RelPosixLink
  takeDirectory = RelPosixLink
    . fromString
    . FPP.takeDirectory
    . toString
    . unRelPosixLink
  
  -- | 'FilePath.takeExtension' version for 'RelPosixLink'.
  takeExtension :: RelPosixLink -> String
  takeExtension = FPP.takeExtension
    . toString
    . unRelPosixLink
  
  -- | 'Check if a 'RelPosixLink' contains any backslash.
  hasBackslash :: RelPosixLink -> Bool
  hasBackslash = ('\\' `elem`)
    . unRelPosixLink
  
  -- | Get the list of directories between a 'RelPosixLink' and its
  -- relative root.
  getIntermediateDirs :: RelPosixLink -> [RelPosixLink]
  getIntermediateDirs link = fmap RelPosixLink $
    case T.splitOn "/" $ unRelPosixLink $ takeDirectory link of
      [] -> []
      ["."] -> [""]
      [".."] -> ["", ".."]
      d : ds -> scanl (\a b -> a <> "/" <> b) d ds
  
  -- | Relative POSIX file path with some normalizations applied.
  --
  -- It should be created from a 'RelPosixLink' via
  -- 'canonicalizeRelPosixLink'.
  newtype CanonicalRelPosixLink = UnsafeCanonicalRelPosixLink
    { unCanonicalRelPosixLink :: RelPosixLink
    } deriving newtype (Show, Eq, Ord, NFData, Buildable, Pretty)
  
  -- | Canonicalize a 'RelPosixLink'.
  --
  -- Applies the following normalizations:
  --
  --  * Drop trailing path separator.
  --
  --  * Expand '.' and '..' indirections syntactically.
  --
  canonicalizeRelPosixLink :: RelPosixLink -> CanonicalRelPosixLink
  canonicalizeRelPosixLink = UnsafeCanonicalRelPosixLink
    . RelPosixLink
    . expandPosixIndirections
    . dropTrailingPosixPathSeparator
    . withPathSeparator FPP.pathSeparator
    . unRelPosixLink
  
  -- | Check if a 'CanonicalRelPosixLink' passes through its relative root when
  -- expanding indirections.
  hasUnexpanededParentIndirections :: CanonicalRelPosixLink -> Bool
  hasUnexpanededParentIndirections = elem ".."
    . T.splitOn "/"
    . unRelPosixLink
    . unCanonicalRelPosixLink
  
  -- | Relative Glob pattern with some normalizations applied.
  --
  -- It should be created via 'mkCanonicalRelGlobPattern'.
  newtype CanonicalRelGlobPattern = UnsafeCanonicalRelGlobPattern
    { unCanonicalRelGlobPattern :: Glob.Pattern
    }
  
  -- | Create a CanonicalRelGlobPattern from a 'ToString' instance value that
  -- represents a POSIX glob pattern.
  --
  -- Applies the following normalizations:
  --
  --  * Drop trailing path separator.
  --
  --  * FilePath.Posix.normalise.
  --
  --  * Expand '.' and '..' indirections syntactically.
  --
  mkCanonicalRelGlobPattern :: ToString s => s -> Either String CanonicalRelGlobPattern
  mkCanonicalRelGlobPattern path = do
    let spath = toString path
    unless (FPP.isRelative spath) $ Left $
      "Expected a relative glob pattern, but got " <> spath
    -- Checking correctness of glob, e.g. "a[b" is incorrect
    case Glob.tryCompileWith globCompileOptions (normalise spath) of
      Right pat -> return $ UnsafeCanonicalRelGlobPattern pat
      Left err -> Left
          [int||
          Glob pattern compilation failed.
          Error message is:
          #{err}
          The syntax for glob patterns is described here:
          https://hackage.haskell.org/package/Glob/docs/System-FilePath-Glob.html#v:compile
          Special characters in file names can be escaped using square brackets, e.g. <a> -> [<]a[>].
          |]
    where
      normalise = toString
        . expandPosixIndirections
        . fromString
        . FPP.normalise
        . FPP.dropTrailingPathSeparator
  
  -- Checks if a 'CanonicalRelPosixLink' matches some of the given
  -- 'CanonicalRelGlobPattern's.
  --
  -- They are considered as relative to the same root.
  matchesGlobPatterns :: [CanonicalRelGlobPattern] -> CanonicalRelPosixLink -> Bool
  matchesGlobPatterns globPatterns file = or
    [ Glob.match pat . toString . unRelPosixLink . unCanonicalRelPosixLink $ file
    | UnsafeCanonicalRelGlobPattern pat <- globPatterns
    ]
  
  instance FromJSON CanonicalRelGlobPattern where
    parseJSON = withText "Repo-relative glob pattern" $
      either fail pure . mkCanonicalRelGlobPattern
  
  -- | Glob compilation options we use.
  globCompileOptions :: Glob.CompOptions
  globCompileOptions = Glob.compDefault{Glob.errorRecovery = False}
  
  dropTrailingPosixPathSeparator :: Text -> Text
  dropTrailingPosixPathSeparator p = fromMaybe p
    $ T.stripSuffix "/" p
  
  -- Expand '.' and '..' in paths with Posix path separators.
  expandPosixIndirections :: Text -> Text
  expandPosixIndirections = T.intercalate "/"
      . reverse
      . expand 0
      . reverse
      . T.split (FPP.isPathSeparator)
    where
      expand :: Int -> [Text] -> [Text]
      expand acc (".." : xs) = expand (acc + 1) xs
      expand acc ("." : xs) = expand acc xs
      expand 0 (x : xs) = x : expand 0 xs
      expand acc (_ : xs) = expand (acc - 1) xs
      expand acc [] = replicate acc ".."
  
  -- Expand '.' and '..' in paths with system-specific path separators.
  expandPathIndirections :: FilePath -> FilePath
  expandPathIndirections = FP.joinPath
      . reverse
      . expand 0
      . reverse
      . map FP.dropTrailingPathSeparator
      . FP.splitPath
    where
      expand :: Int -> [FilePath] -> [FilePath]
      expand acc (".." : xs) = expand (acc + 1) xs
      expand acc ("." : xs) = expand acc xs
      expand 0 (x : xs) = x : expand 0 xs
      expand acc (_ : xs) = expand (acc - 1) xs
      expand acc [] = replicate acc ".."
  
  withPathSeparator :: Char -> Text -> Text
  withPathSeparator pathSep = T.map replaceSeparator
    where
      replaceSeparator :: Char -> Char
      replaceSeparator c
        | FP.isPathSeparator c = pathSep
        | otherwise = c
  
  newtype PrintUnixPaths = PrintUnixPaths Bool
  
  mkPathForPrinting :: Given PrintUnixPaths => FilePath -> String
  mkPathForPrinting = replaceSeparator . expandPathIndirections
    where
      replaceSeparator :: FilePath -> String
      replaceSeparator = case given of
        PrintUnixPaths True  -> map (\c -> if c == FP.pathSeparator then '/' else c)
        PrintUnixPaths False -> id
  