{- 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 :: IO Bool
askWithinCI = FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"CI" IO (Maybe FilePath) -> (Maybe FilePath -> Bool) -> IO Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
  Just FilePath
"1" -> Bool
True
  Just ((Char -> Char) -> FilePath -> FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Char -> Char
C.toLower -> FilePath
"true") -> Bool
True
  Maybe FilePath
_ -> Bool
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
  { RelPosixLink -> Text
unRelPosixLink :: Text
  } deriving newtype (Int -> RelPosixLink -> FilePath -> FilePath
[RelPosixLink] -> FilePath -> FilePath
RelPosixLink -> FilePath
(Int -> RelPosixLink -> FilePath -> FilePath)
-> (RelPosixLink -> FilePath)
-> ([RelPosixLink] -> FilePath -> FilePath)
-> Show RelPosixLink
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> RelPosixLink -> FilePath -> FilePath
showsPrec :: Int -> RelPosixLink -> FilePath -> FilePath
$cshow :: RelPosixLink -> FilePath
show :: RelPosixLink -> FilePath
$cshowList :: [RelPosixLink] -> FilePath -> FilePath
showList :: [RelPosixLink] -> FilePath -> FilePath
Show, RelPosixLink -> RelPosixLink -> Bool
(RelPosixLink -> RelPosixLink -> Bool)
-> (RelPosixLink -> RelPosixLink -> Bool) -> Eq RelPosixLink
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RelPosixLink -> RelPosixLink -> Bool
== :: RelPosixLink -> RelPosixLink -> Bool
$c/= :: RelPosixLink -> RelPosixLink -> Bool
/= :: RelPosixLink -> RelPosixLink -> Bool
Eq, Eq RelPosixLink
Eq RelPosixLink =>
(RelPosixLink -> RelPosixLink -> Ordering)
-> (RelPosixLink -> RelPosixLink -> Bool)
-> (RelPosixLink -> RelPosixLink -> Bool)
-> (RelPosixLink -> RelPosixLink -> Bool)
-> (RelPosixLink -> RelPosixLink -> Bool)
-> (RelPosixLink -> RelPosixLink -> RelPosixLink)
-> (RelPosixLink -> RelPosixLink -> RelPosixLink)
-> Ord RelPosixLink
RelPosixLink -> RelPosixLink -> Bool
RelPosixLink -> RelPosixLink -> Ordering
RelPosixLink -> RelPosixLink -> RelPosixLink
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: RelPosixLink -> RelPosixLink -> Ordering
compare :: RelPosixLink -> RelPosixLink -> Ordering
$c< :: RelPosixLink -> RelPosixLink -> Bool
< :: RelPosixLink -> RelPosixLink -> Bool
$c<= :: RelPosixLink -> RelPosixLink -> Bool
<= :: RelPosixLink -> RelPosixLink -> Bool
$c> :: RelPosixLink -> RelPosixLink -> Bool
> :: RelPosixLink -> RelPosixLink -> Bool
$c>= :: RelPosixLink -> RelPosixLink -> Bool
>= :: RelPosixLink -> RelPosixLink -> Bool
$cmax :: RelPosixLink -> RelPosixLink -> RelPosixLink
max :: RelPosixLink -> RelPosixLink -> RelPosixLink
$cmin :: RelPosixLink -> RelPosixLink -> RelPosixLink
min :: RelPosixLink -> RelPosixLink -> RelPosixLink
Ord, RelPosixLink -> ()
(RelPosixLink -> ()) -> NFData RelPosixLink
forall a. (a -> ()) -> NFData a
$crnf :: RelPosixLink -> ()
rnf :: RelPosixLink -> ()
NFData, RelPosixLink -> Builder
(RelPosixLink -> Builder) -> Buildable RelPosixLink
forall p. (p -> Builder) -> Buildable p
$cbuild :: RelPosixLink -> Builder
build :: RelPosixLink -> Builder
Buildable, Style -> RelPosixLink -> RelPosixLink
Color -> RelPosixLink -> RelPosixLink
Section -> Color -> RelPosixLink -> RelPosixLink
(Color -> RelPosixLink -> RelPosixLink)
-> (Color -> RelPosixLink -> RelPosixLink)
-> (Section -> Color -> RelPosixLink -> RelPosixLink)
-> (Style -> RelPosixLink -> RelPosixLink)
-> Pretty RelPosixLink
forall a.
(Color -> a -> a)
-> (Color -> a -> a)
-> (Section -> Color -> a -> a)
-> (Style -> a -> a)
-> Pretty a
$ccolor :: Color -> RelPosixLink -> RelPosixLink
color :: Color -> RelPosixLink -> RelPosixLink
$cbgColor :: Color -> RelPosixLink -> RelPosixLink
bgColor :: Color -> RelPosixLink -> RelPosixLink
$ccolorize :: Section -> Color -> RelPosixLink -> RelPosixLink
colorize :: Section -> Color -> RelPosixLink -> RelPosixLink
$cstyle :: Style -> RelPosixLink -> RelPosixLink
style :: Style -> RelPosixLink -> RelPosixLink
Pretty)

-- | Create a POSIX file path from a platform-dependent one.
mkRelPosixLink :: FilePath -> RelPosixLink
mkRelPosixLink :: FilePath -> RelPosixLink
mkRelPosixLink = Text -> RelPosixLink
RelPosixLink
  (Text -> RelPosixLink)
-> (FilePath -> Text) -> FilePath -> RelPosixLink
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text -> Text
withPathSeparator Char
FPP.pathSeparator
  (Text -> Text) -> (FilePath -> Text) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
forall a. IsString a => FilePath -> a
fromString

-- | Join two 'RelPosixLink's.
(</>) :: RelPosixLink -> RelPosixLink -> RelPosixLink
RelPosixLink Text
a </> :: RelPosixLink -> RelPosixLink -> RelPosixLink
</> RelPosixLink Text
b =
  let a' :: Text
a' = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
a (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripSuffix Text
"/" Text
a
      b' :: Text
b' = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
b (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripPrefix Text
"./" Text
a
  in case (Text
a', Text
b') of
        (Text
"", Text
_) -> Text -> RelPosixLink
RelPosixLink Text
b
        (Text
".", Text
_) -> Text -> RelPosixLink
RelPosixLink Text
b
        (Text, Text)
_ -> Text -> RelPosixLink
RelPosixLink (Text -> RelPosixLink) -> Text -> RelPosixLink
forall a b. (a -> b) -> a -> b
$ Text
a' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
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 :: FilePath -> RelPosixLink -> FilePath
filePathFromRoot FilePath
rootPath = (FilePath
rootPath FilePath -> FilePath -> FilePath
FP.</>)
  (FilePath -> FilePath)
-> (RelPosixLink -> FilePath) -> RelPosixLink -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
forall a. ToString a => a -> FilePath
toString
  (Text -> FilePath)
-> (RelPosixLink -> Text) -> RelPosixLink -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text -> Text
withPathSeparator Char
FP.pathSeparator
  (Text -> Text) -> (RelPosixLink -> Text) -> RelPosixLink -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelPosixLink -> Text
unRelPosixLink

-- | 'FilePath.takeDirectory' version for 'RelPosixLink'.
takeDirectory :: RelPosixLink -> RelPosixLink
takeDirectory :: RelPosixLink -> RelPosixLink
takeDirectory = Text -> RelPosixLink
RelPosixLink
  (Text -> RelPosixLink)
-> (RelPosixLink -> Text) -> RelPosixLink -> RelPosixLink
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
forall a. IsString a => FilePath -> a
fromString
  (FilePath -> Text)
-> (RelPosixLink -> FilePath) -> RelPosixLink -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
FPP.takeDirectory
  (FilePath -> FilePath)
-> (RelPosixLink -> FilePath) -> RelPosixLink -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
forall a. ToString a => a -> FilePath
toString
  (Text -> FilePath)
-> (RelPosixLink -> Text) -> RelPosixLink -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelPosixLink -> Text
unRelPosixLink

-- | 'FilePath.takeExtension' version for 'RelPosixLink'.
takeExtension :: RelPosixLink -> String
takeExtension :: RelPosixLink -> FilePath
takeExtension = FilePath -> FilePath
FPP.takeExtension
  (FilePath -> FilePath)
-> (RelPosixLink -> FilePath) -> RelPosixLink -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
forall a. ToString a => a -> FilePath
toString
  (Text -> FilePath)
-> (RelPosixLink -> Text) -> RelPosixLink -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelPosixLink -> Text
unRelPosixLink

-- | 'Check if a 'RelPosixLink' contains any backslash.
hasBackslash :: RelPosixLink -> Bool
hasBackslash :: RelPosixLink -> Bool
hasBackslash = (Char
Element Text
'\\' Element Text -> Text -> Bool
forall t. (Container t, Eq (Element t)) => Element t -> t -> Bool
`elem`)
  (Text -> Bool) -> (RelPosixLink -> Text) -> RelPosixLink -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelPosixLink -> Text
unRelPosixLink

-- | Get the list of directories between a 'RelPosixLink' and its
-- relative root.
getIntermediateDirs :: RelPosixLink -> [RelPosixLink]
getIntermediateDirs :: RelPosixLink -> [RelPosixLink]
getIntermediateDirs RelPosixLink
link = (Text -> RelPosixLink) -> [Text] -> [RelPosixLink]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> RelPosixLink
RelPosixLink ([Text] -> [RelPosixLink]) -> [Text] -> [RelPosixLink]
forall a b. (a -> b) -> a -> b
$
  case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/" (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ RelPosixLink -> Text
unRelPosixLink (RelPosixLink -> Text) -> RelPosixLink -> Text
forall a b. (a -> b) -> a -> b
$ RelPosixLink -> RelPosixLink
takeDirectory RelPosixLink
link of
    [] -> []
    [Text
"."] -> [Text
""]
    [Text
".."] -> [Text
"", Text
".."]
    Text
d : [Text]
ds -> (Text -> Text -> Text) -> Text -> [Text] -> [Text]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl (\Text
a Text
b -> Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b) Text
d [Text]
ds

-- | Relative POSIX file path with some normalizations applied.
--
-- It should be created from a 'RelPosixLink' via
-- 'canonicalizeRelPosixLink'.
newtype CanonicalRelPosixLink = UnsafeCanonicalRelPosixLink
  { CanonicalRelPosixLink -> RelPosixLink
unCanonicalRelPosixLink :: RelPosixLink
  } deriving newtype (Int -> CanonicalRelPosixLink -> FilePath -> FilePath
[CanonicalRelPosixLink] -> FilePath -> FilePath
CanonicalRelPosixLink -> FilePath
(Int -> CanonicalRelPosixLink -> FilePath -> FilePath)
-> (CanonicalRelPosixLink -> FilePath)
-> ([CanonicalRelPosixLink] -> FilePath -> FilePath)
-> Show CanonicalRelPosixLink
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> CanonicalRelPosixLink -> FilePath -> FilePath
showsPrec :: Int -> CanonicalRelPosixLink -> FilePath -> FilePath
$cshow :: CanonicalRelPosixLink -> FilePath
show :: CanonicalRelPosixLink -> FilePath
$cshowList :: [CanonicalRelPosixLink] -> FilePath -> FilePath
showList :: [CanonicalRelPosixLink] -> FilePath -> FilePath
Show, CanonicalRelPosixLink -> CanonicalRelPosixLink -> Bool
(CanonicalRelPosixLink -> CanonicalRelPosixLink -> Bool)
-> (CanonicalRelPosixLink -> CanonicalRelPosixLink -> Bool)
-> Eq CanonicalRelPosixLink
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CanonicalRelPosixLink -> CanonicalRelPosixLink -> Bool
== :: CanonicalRelPosixLink -> CanonicalRelPosixLink -> Bool
$c/= :: CanonicalRelPosixLink -> CanonicalRelPosixLink -> Bool
/= :: CanonicalRelPosixLink -> CanonicalRelPosixLink -> Bool
Eq, Eq CanonicalRelPosixLink
Eq CanonicalRelPosixLink =>
(CanonicalRelPosixLink -> CanonicalRelPosixLink -> Ordering)
-> (CanonicalRelPosixLink -> CanonicalRelPosixLink -> Bool)
-> (CanonicalRelPosixLink -> CanonicalRelPosixLink -> Bool)
-> (CanonicalRelPosixLink -> CanonicalRelPosixLink -> Bool)
-> (CanonicalRelPosixLink -> CanonicalRelPosixLink -> Bool)
-> (CanonicalRelPosixLink
    -> CanonicalRelPosixLink -> CanonicalRelPosixLink)
-> (CanonicalRelPosixLink
    -> CanonicalRelPosixLink -> CanonicalRelPosixLink)
-> Ord CanonicalRelPosixLink
CanonicalRelPosixLink -> CanonicalRelPosixLink -> Bool
CanonicalRelPosixLink -> CanonicalRelPosixLink -> Ordering
CanonicalRelPosixLink
-> CanonicalRelPosixLink -> CanonicalRelPosixLink
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CanonicalRelPosixLink -> CanonicalRelPosixLink -> Ordering
compare :: CanonicalRelPosixLink -> CanonicalRelPosixLink -> Ordering
$c< :: CanonicalRelPosixLink -> CanonicalRelPosixLink -> Bool
< :: CanonicalRelPosixLink -> CanonicalRelPosixLink -> Bool
$c<= :: CanonicalRelPosixLink -> CanonicalRelPosixLink -> Bool
<= :: CanonicalRelPosixLink -> CanonicalRelPosixLink -> Bool
$c> :: CanonicalRelPosixLink -> CanonicalRelPosixLink -> Bool
> :: CanonicalRelPosixLink -> CanonicalRelPosixLink -> Bool
$c>= :: CanonicalRelPosixLink -> CanonicalRelPosixLink -> Bool
>= :: CanonicalRelPosixLink -> CanonicalRelPosixLink -> Bool
$cmax :: CanonicalRelPosixLink
-> CanonicalRelPosixLink -> CanonicalRelPosixLink
max :: CanonicalRelPosixLink
-> CanonicalRelPosixLink -> CanonicalRelPosixLink
$cmin :: CanonicalRelPosixLink
-> CanonicalRelPosixLink -> CanonicalRelPosixLink
min :: CanonicalRelPosixLink
-> CanonicalRelPosixLink -> CanonicalRelPosixLink
Ord, CanonicalRelPosixLink -> ()
(CanonicalRelPosixLink -> ()) -> NFData CanonicalRelPosixLink
forall a. (a -> ()) -> NFData a
$crnf :: CanonicalRelPosixLink -> ()
rnf :: CanonicalRelPosixLink -> ()
NFData, CanonicalRelPosixLink -> Builder
(CanonicalRelPosixLink -> Builder)
-> Buildable CanonicalRelPosixLink
forall p. (p -> Builder) -> Buildable p
$cbuild :: CanonicalRelPosixLink -> Builder
build :: CanonicalRelPosixLink -> Builder
Buildable, Style -> CanonicalRelPosixLink -> CanonicalRelPosixLink
Color -> CanonicalRelPosixLink -> CanonicalRelPosixLink
Section -> Color -> CanonicalRelPosixLink -> CanonicalRelPosixLink
(Color -> CanonicalRelPosixLink -> CanonicalRelPosixLink)
-> (Color -> CanonicalRelPosixLink -> CanonicalRelPosixLink)
-> (Section
    -> Color -> CanonicalRelPosixLink -> CanonicalRelPosixLink)
-> (Style -> CanonicalRelPosixLink -> CanonicalRelPosixLink)
-> Pretty CanonicalRelPosixLink
forall a.
(Color -> a -> a)
-> (Color -> a -> a)
-> (Section -> Color -> a -> a)
-> (Style -> a -> a)
-> Pretty a
$ccolor :: Color -> CanonicalRelPosixLink -> CanonicalRelPosixLink
color :: Color -> CanonicalRelPosixLink -> CanonicalRelPosixLink
$cbgColor :: Color -> CanonicalRelPosixLink -> CanonicalRelPosixLink
bgColor :: Color -> CanonicalRelPosixLink -> CanonicalRelPosixLink
$ccolorize :: Section -> Color -> CanonicalRelPosixLink -> CanonicalRelPosixLink
colorize :: Section -> Color -> CanonicalRelPosixLink -> CanonicalRelPosixLink
$cstyle :: Style -> CanonicalRelPosixLink -> CanonicalRelPosixLink
style :: Style -> CanonicalRelPosixLink -> CanonicalRelPosixLink
Pretty)

-- | Canonicalize a 'RelPosixLink'.
--
-- Applies the following normalizations:
--
--  * Drop trailing path separator.
--
--  * Expand '.' and '..' indirections syntactically.
--
canonicalizeRelPosixLink :: RelPosixLink -> CanonicalRelPosixLink
canonicalizeRelPosixLink :: RelPosixLink -> CanonicalRelPosixLink
canonicalizeRelPosixLink = RelPosixLink -> CanonicalRelPosixLink
UnsafeCanonicalRelPosixLink
  (RelPosixLink -> CanonicalRelPosixLink)
-> (RelPosixLink -> RelPosixLink)
-> RelPosixLink
-> CanonicalRelPosixLink
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> RelPosixLink
RelPosixLink
  (Text -> RelPosixLink)
-> (RelPosixLink -> Text) -> RelPosixLink -> RelPosixLink
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
expandPosixIndirections
  (Text -> Text) -> (RelPosixLink -> Text) -> RelPosixLink -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
dropTrailingPosixPathSeparator
  (Text -> Text) -> (RelPosixLink -> Text) -> RelPosixLink -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text -> Text
withPathSeparator Char
FPP.pathSeparator
  (Text -> Text) -> (RelPosixLink -> Text) -> RelPosixLink -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelPosixLink -> Text
unRelPosixLink

-- | Check if a 'CanonicalRelPosixLink' passes through its relative root when
-- expanding indirections.
hasUnexpanededParentIndirections :: CanonicalRelPosixLink -> Bool
hasUnexpanededParentIndirections :: CanonicalRelPosixLink -> Bool
hasUnexpanededParentIndirections = Element [Text] -> [Text] -> Bool
forall t. (Container t, Eq (Element t)) => Element t -> t -> Bool
elem Text
Element [Text]
".."
  ([Text] -> Bool)
-> (CanonicalRelPosixLink -> [Text])
-> CanonicalRelPosixLink
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/"
  (Text -> [Text])
-> (CanonicalRelPosixLink -> Text)
-> CanonicalRelPosixLink
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelPosixLink -> Text
unRelPosixLink
  (RelPosixLink -> Text)
-> (CanonicalRelPosixLink -> RelPosixLink)
-> CanonicalRelPosixLink
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CanonicalRelPosixLink -> RelPosixLink
unCanonicalRelPosixLink

-- | Relative Glob pattern with some normalizations applied.
--
-- It should be created via 'mkCanonicalRelGlobPattern'.
newtype CanonicalRelGlobPattern = UnsafeCanonicalRelGlobPattern
  { CanonicalRelGlobPattern -> Pattern
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 :: forall s.
ToString s =>
s -> Either FilePath CanonicalRelGlobPattern
mkCanonicalRelGlobPattern s
path = do
  let spath :: FilePath
spath = s -> FilePath
forall a. ToString a => a -> FilePath
toString s
path
  Bool -> Either FilePath () -> Either FilePath ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FilePath -> Bool
FPP.isRelative FilePath
spath) (Either FilePath () -> Either FilePath ())
-> Either FilePath () -> Either FilePath ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath ()
forall a b. a -> Either a b
Left (FilePath -> Either FilePath ()) -> FilePath -> Either FilePath ()
forall a b. (a -> b) -> a -> b
$
    FilePath
"Expected a relative glob pattern, but got " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
spath
  -- Checking correctness of glob, e.g. "a[b" is incorrect
  case CompOptions -> FilePath -> Either FilePath Pattern
Glob.tryCompileWith CompOptions
globCompileOptions (FilePath -> FilePath
normalise FilePath
spath) of
    Right Pattern
pat -> CanonicalRelGlobPattern -> Either FilePath CanonicalRelGlobPattern
forall a. a -> Either FilePath a
forall (m :: * -> *) a. Monad m => a -> m a
return (CanonicalRelGlobPattern
 -> Either FilePath CanonicalRelGlobPattern)
-> CanonicalRelGlobPattern
-> Either FilePath CanonicalRelGlobPattern
forall a b. (a -> b) -> a -> b
$ Pattern -> CanonicalRelGlobPattern
UnsafeCanonicalRelGlobPattern Pattern
pat
    Left FilePath
err -> FilePath -> Either FilePath CanonicalRelGlobPattern
forall a b. a -> Either a b
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 :: FilePath -> FilePath
normalise = Text -> FilePath
forall a. ToString a => a -> FilePath
toString
      (Text -> FilePath) -> (FilePath -> Text) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
expandPosixIndirections
      (Text -> Text) -> (FilePath -> Text) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
forall a. IsString a => FilePath -> a
fromString
      (FilePath -> Text) -> (FilePath -> FilePath) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
FPP.normalise
      (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
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 :: [CanonicalRelGlobPattern] -> CanonicalRelPosixLink -> Bool
matchesGlobPatterns [CanonicalRelGlobPattern]
globPatterns CanonicalRelPosixLink
file = [Bool] -> Bool
forall t. (Container t, Element t ~ Bool) => t -> Bool
or
  [ Pattern -> FilePath -> Bool
Glob.match Pattern
pat (FilePath -> Bool)
-> (CanonicalRelPosixLink -> FilePath)
-> CanonicalRelPosixLink
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
forall a. ToString a => a -> FilePath
toString (Text -> FilePath)
-> (CanonicalRelPosixLink -> Text)
-> CanonicalRelPosixLink
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelPosixLink -> Text
unRelPosixLink (RelPosixLink -> Text)
-> (CanonicalRelPosixLink -> RelPosixLink)
-> CanonicalRelPosixLink
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CanonicalRelPosixLink -> RelPosixLink
unCanonicalRelPosixLink (CanonicalRelPosixLink -> Bool) -> CanonicalRelPosixLink -> Bool
forall a b. (a -> b) -> a -> b
$ CanonicalRelPosixLink
file
  | UnsafeCanonicalRelGlobPattern Pattern
pat <- [CanonicalRelGlobPattern]
globPatterns
  ]

instance FromJSON CanonicalRelGlobPattern where
  parseJSON :: Value -> Parser CanonicalRelGlobPattern
parseJSON = FilePath
-> (Text -> Parser CanonicalRelGlobPattern)
-> Value
-> Parser CanonicalRelGlobPattern
forall a. FilePath -> (Text -> Parser a) -> Value -> Parser a
withText FilePath
"Repo-relative glob pattern" ((Text -> Parser CanonicalRelGlobPattern)
 -> Value -> Parser CanonicalRelGlobPattern)
-> (Text -> Parser CanonicalRelGlobPattern)
-> Value
-> Parser CanonicalRelGlobPattern
forall a b. (a -> b) -> a -> b
$
    (FilePath -> Parser CanonicalRelGlobPattern)
-> (CanonicalRelGlobPattern -> Parser CanonicalRelGlobPattern)
-> Either FilePath CanonicalRelGlobPattern
-> Parser CanonicalRelGlobPattern
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> Parser CanonicalRelGlobPattern
forall a. FilePath -> Parser a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail CanonicalRelGlobPattern -> Parser CanonicalRelGlobPattern
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath CanonicalRelGlobPattern
 -> Parser CanonicalRelGlobPattern)
-> (Text -> Either FilePath CanonicalRelGlobPattern)
-> Text
-> Parser CanonicalRelGlobPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either FilePath CanonicalRelGlobPattern
forall s.
ToString s =>
s -> Either FilePath CanonicalRelGlobPattern
mkCanonicalRelGlobPattern

-- | Glob compilation options we use.
globCompileOptions :: Glob.CompOptions
globCompileOptions :: CompOptions
globCompileOptions = CompOptions
Glob.compDefault{Glob.errorRecovery = False}

dropTrailingPosixPathSeparator :: Text -> Text
dropTrailingPosixPathSeparator :: Text -> Text
dropTrailingPosixPathSeparator Text
p = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
p
  (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripSuffix Text
"/" Text
p

-- Expand '.' and '..' in paths with Posix path separators.
expandPosixIndirections :: Text -> Text
expandPosixIndirections :: Text -> Text
expandPosixIndirections = Text -> [Text] -> Text
T.intercalate Text
"/"
    ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse
    ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Text] -> [Text]
expand Int
0
    ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse
    ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split (Char -> Bool
FPP.isPathSeparator)
  where
    expand :: Int -> [Text] -> [Text]
    expand :: Int -> [Text] -> [Text]
expand Int
acc (Text
".." : [Text]
xs) = Int -> [Text] -> [Text]
expand (Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Text]
xs
    expand Int
acc (Text
"." : [Text]
xs) = Int -> [Text] -> [Text]
expand Int
acc [Text]
xs
    expand Int
0 (Text
x : [Text]
xs) = Text
x Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Int -> [Text] -> [Text]
expand Int
0 [Text]
xs
    expand Int
acc (Text
_ : [Text]
xs) = Int -> [Text] -> [Text]
expand (Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Text]
xs
    expand Int
acc [] = Int -> Text -> [Text]
forall a. Int -> a -> [a]
replicate Int
acc Text
".."

-- Expand '.' and '..' in paths with system-specific path separators.
expandPathIndirections :: FilePath -> FilePath
expandPathIndirections :: FilePath -> FilePath
expandPathIndirections = [FilePath] -> FilePath
FP.joinPath
    ([FilePath] -> FilePath)
-> (FilePath -> [FilePath]) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse
    ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [FilePath] -> [FilePath]
expand Int
0
    ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse
    ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map FilePath -> FilePath
FP.dropTrailingPathSeparator
    ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
FP.splitPath
  where
    expand :: Int -> [FilePath] -> [FilePath]
    expand :: Int -> [FilePath] -> [FilePath]
expand Int
acc (FilePath
".." : [FilePath]
xs) = Int -> [FilePath] -> [FilePath]
expand (Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [FilePath]
xs
    expand Int
acc (FilePath
"." : [FilePath]
xs) = Int -> [FilePath] -> [FilePath]
expand Int
acc [FilePath]
xs
    expand Int
0 (FilePath
x : [FilePath]
xs) = FilePath
x FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: Int -> [FilePath] -> [FilePath]
expand Int
0 [FilePath]
xs
    expand Int
acc (FilePath
_ : [FilePath]
xs) = Int -> [FilePath] -> [FilePath]
expand (Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [FilePath]
xs
    expand Int
acc [] = Int -> FilePath -> [FilePath]
forall a. Int -> a -> [a]
replicate Int
acc FilePath
".."

withPathSeparator :: Char -> Text -> Text
withPathSeparator :: Char -> Text -> Text
withPathSeparator Char
pathSep = (Char -> Char) -> Text -> Text
T.map Char -> Char
replaceSeparator
  where
    replaceSeparator :: Char -> Char
    replaceSeparator :: Char -> Char
replaceSeparator Char
c
      | Char -> Bool
FP.isPathSeparator Char
c = Char
pathSep
      | Bool
otherwise = Char
c

newtype PrintUnixPaths = PrintUnixPaths Bool

mkPathForPrinting :: Given PrintUnixPaths => FilePath -> String
mkPathForPrinting :: Given PrintUnixPaths => FilePath -> FilePath
mkPathForPrinting = FilePath -> FilePath
replaceSeparator (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
expandPathIndirections
  where
    replaceSeparator :: FilePath -> String
    replaceSeparator :: FilePath -> FilePath
replaceSeparator = case PrintUnixPaths
forall a. Given a => a
given of
      PrintUnixPaths Bool
True  -> (Char -> Char) -> FilePath -> FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
FP.pathSeparator then Char
'/' else Char
c)
      PrintUnixPaths Bool
False -> FilePath -> FilePath
forall a. a -> a
id