Cabal/src/Distribution/Simple/Glob.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE DeriveFunctor #-}
   3 {-# LANGUAGE DeriveGeneric #-}
   4 {-# LANGUAGE LambdaCase #-}
   5 {-# LANGUAGE RankNTypes #-}
   6
   7 -----------------------------------------------------------------------------
   8
   9 -- |
  10 -- Module      :  Distribution.Simple.Glob
  11 -- Copyright   :  Isaac Jones, Simon Marlow 2003-2004
  12 -- License     :  BSD3
  13 --                portions Copyright (c) 2007, Galois Inc.
  14 --
  15 -- Maintainer  :  cabal-devel@haskell.org
  16 -- Portability :  portable
  17 --
  18 -- Simple file globbing.
  19 module Distribution.Simple.Glob
  20   ( -- * Globs
  21     Glob
  22
  23     -- * Matching on globs
  24   , GlobResult (..)
  25   , globMatches
  26   , fileGlobMatches
  27   , matchGlob
  28   , matchGlobPieces
  29   , matchDirFileGlob
  30   , matchDirFileGlobWithDie
  31   , runDirFileGlob
  32
  33     -- * Parsing globs
  34   , parseFileGlob
  35   , GlobSyntaxError (..)
  36   , explainGlobSyntaxError
  37
  38     -- * Utility
  39   , isRecursiveInRoot
  40   )
  41 where
  42
  43 import Distribution.Compat.Prelude
  44 import Prelude ()
  45
  46 import Distribution.CabalSpecVersion
  47   ( CabalSpecVersion (..)
  48   )
  49 import Distribution.Pretty
  50 import Distribution.Simple.Errors
  51   ( CabalException (MatchDirFileGlob, MatchDirFileGlobErrors)
  52   )
  53 import Distribution.Simple.Glob.Internal
  54 import Distribution.Simple.Utils
  55   ( debug
  56   , dieWithException
  57   , getDirectoryContentsRecursive
  58   , warn
  59   )
  60 import Distribution.Utils.Path
  61 import Distribution.Verbosity
  62   ( Verbosity
  63   , silent
  64   )
  65
  66 import Control.Monad (mapM)
  67 import Data.List (stripPrefix)
  68 import System.Directory
  69 import System.FilePath hiding ((<.>), (</>))
  70
  71 -------------------------------------------------------------------------------
  72
  73 -- * Matching
  74
  75 --------------------------------------------------------------------------------
  76
  77 -- | Match a 'Glob' against the file system, starting from a
  78 -- given root directory. The results are all relative to the given root.
  79 --
  80 -- @since 3.12.0.0
  81 matchGlob :: FilePath -> Glob -> IO [FilePath]
  82 matchGlob root glob =
  83   -- For this function, which is the general globbing one (doesn't care about
  84   -- cabal spec, used e.g. for monitoring), we consider all matches.
  85   mapMaybe
  86     ( \case
  87         GlobMatch a -> Just a
  88         GlobWarnMultiDot a -> Just a
  89         GlobMatchesDirectory a -> Just a
  90         GlobMissingDirectory{} -> Nothing
  91     )
  92     <$> runDirFileGlob silent Nothing root glob
  93
  94 -- | Match a globbing pattern against a file path component
  95 matchGlobPieces :: GlobPieces -> String -> Bool
  96 matchGlobPieces = goStart
  97   where
  98     -- From the man page, glob(7):
  99     --   "If a filename starts with a '.', this character must be
 100     --    matched explicitly."
 101
 102     go, goStart :: [GlobPiece] -> String -> Bool
 103
 104     goStart (WildCard : _) ('.' : _) = False
 105     goStart (Union globs : rest) cs =
 106       any
 107         (\glob -> goStart (glob ++ rest) cs)
 108         globs
 109     goStart rest cs = go rest cs
 110
 111     go [] "" = True
 112     go (Literal lit : rest) cs
 113       | Just cs' <- stripPrefix lit cs =
 114           go rest cs'
 115       | otherwise = False
 116     go [WildCard] "" = True
 117     go (WildCard : rest) (c : cs) = go rest (c : cs) || go (WildCard : rest) cs
 118     go (Union globs : rest) cs = any (\glob -> go (glob ++ rest) cs) globs
 119     go [] (_ : _) = False
 120     go (_ : _) "" = False
 121
 122 -- | Extract the matches from a list of 'GlobResult's.
 123 --
 124 -- Note: throws away the 'GlobMissingDirectory' results; chances are
 125 -- that you want to check for these and error out if any are present.
 126 --
 127 -- @since 3.12.0.0
 128 globMatches :: [GlobResult a] -> [a]
 129 globMatches input = [a | GlobMatch a <- input]
 130
 131 -- | This will 'die'' when the glob matches no files, or if the glob
 132 -- refers to a missing directory, or if the glob fails to parse.
 133 --
 134 -- The 'Version' argument must be the spec version of the package
 135 -- description being processed, as globs behave slightly differently
 136 -- in different spec versions.
 137 --
 138 -- The first 'FilePath' argument is the directory that the glob is
 139 -- relative to. It must be a valid directory (and hence it can't be
 140 -- the empty string). The returned values will not include this
 141 -- prefix.
 142 --
 143 -- The second 'FilePath' is the glob itself.
 144 matchDirFileGlob
 145   :: Verbosity
 146   -> CabalSpecVersion
 147   -> Maybe (SymbolicPath CWD (Dir dir))
 148   -> SymbolicPathX allowAbs dir file
 149   -> IO [SymbolicPathX allowAbs dir file]
 150 matchDirFileGlob v = matchDirFileGlobWithDie v dieWithException
 151
 152 -- | Like 'matchDirFileGlob' but with customizable 'die'
 153 --
 154 -- @since 3.6.0.0
 155 matchDirFileGlobWithDie
 156   :: Verbosity
 157   -> (forall res. Verbosity -> CabalException -> IO [res])
 158   -> CabalSpecVersion
 159   -> Maybe (SymbolicPath CWD (Dir dir))
 160   -> SymbolicPathX allowAbs dir file
 161   -> IO [SymbolicPathX allowAbs dir file]
 162 matchDirFileGlobWithDie verbosity rip version mbWorkDir symPath =
 163   let rawFilePath = getSymbolicPath symPath
 164       dir = maybe "." getSymbolicPath mbWorkDir
 165    in case parseFileGlob version rawFilePath of
 166         Left err -> rip verbosity $ MatchDirFileGlob (explainGlobSyntaxError rawFilePath err)
 167         Right glob -> do
 168           results <- runDirFileGlob verbosity (Just version) dir glob
 169           let missingDirectories =
 170                 [missingDir | GlobMissingDirectory missingDir <- results]
 171               matches = globMatches results
 172               directoryMatches = [a | GlobMatchesDirectory a <- results]
 173
 174           let errors :: [String]
 175               errors =
 176                 [ "filepath wildcard '"
 177                   ++ rawFilePath
 178                   ++ "' refers to the directory"
 179                   ++ " '"
 180                   ++ missingDir
 181                   ++ "', which does not exist or is not a directory."
 182                 | missingDir <- missingDirectories
 183                 ]
 184                   ++ [ "filepath wildcard '" ++ rawFilePath ++ "' does not match any files."
 185                      | null matches && null directoryMatches
 186                      -- we don't error out on directory matches, simply warn about them and ignore.
 187                      ]
 188
 189               warns :: [String]
 190               warns =
 191                 [ "Ignoring directory '" ++ path ++ "'" ++ " listed in a Cabal package field which should only include files (not directories)."
 192                 | path <- directoryMatches
 193                 ]
 194
 195           if null errors
 196             then do
 197               unless (null warns) $
 198                 warn verbosity $
 199                   unlines warns
 200               return $ map unsafeMakeSymbolicPath matches
 201             else rip verbosity $ MatchDirFileGlobErrors errors
 202
 203 -------------------------------------------------------------------------------
 204
 205 -- * Parsing & printing
 206
 207 --------------------------------------------------------------------------------
 208 -- Filepaths with globs may be parsed in the special context is globbing in
 209 -- cabal package fields, such as `data-files`. In that case, we restrict the
 210 -- globbing syntax to that supported by the cabal spec version in use.
 211 -- Otherwise, we parse the globs to the extent of our globbing features
 212 -- (wildcards `*`, unions `{a,b,c}`, and directory-recursive wildcards `**`).
 213
 214 -- ** Parsing globs in a cabal package
 215
 216 parseFileGlob :: CabalSpecVersion -> FilePath -> Either GlobSyntaxError Glob
 217 parseFileGlob version filepath = case reverse (splitDirectories filepath) of
 218   [] ->
 219     Left EmptyGlob
 220   (filename : "**" : segments)
 221     | allowGlobStar -> do
 222         finalSegment <- case splitExtensions filename of
 223           ("*", ext)
 224             | '*' `elem` ext -> Left StarInExtension
 225             | null ext -> Left NoExtensionOnStar
 226             | otherwise -> Right (GlobDirRecursive [WildCard, Literal ext])
 227           _
 228             | allowLiteralFilenameGlobStar ->
 229                 Right (GlobDirRecursive [Literal filename])
 230             | otherwise ->
 231                 Left LiteralFileNameGlobStar
 232
 233         foldM addStem finalSegment segments
 234     | otherwise -> Left VersionDoesNotSupportGlobStar
 235   (filename : segments) -> do
 236     pat <- case splitExtensions filename of
 237       ("*", ext)
 238         | not allowGlob -> Left VersionDoesNotSupportGlob
 239         | '*' `elem` ext -> Left StarInExtension
 240         | null ext -> Left NoExtensionOnStar
 241         | otherwise -> Right (GlobFile [WildCard, Literal ext])
 242       (_, ext)
 243         | '*' `elem` ext -> Left StarInExtension
 244         | '*' `elem` filename -> Left StarInFileName
 245         | otherwise -> Right (GlobFile [Literal filename])
 246
 247     foldM addStem pat segments
 248   where
 249     addStem pat seg
 250       | '*' `elem` seg = Left StarInDirectory
 251       | otherwise = Right (GlobDir [Literal seg] pat)
 252     allowGlob = version >= CabalSpecV1_6
 253     allowGlobStar = version >= CabalSpecV2_4
 254     allowLiteralFilenameGlobStar = version >= CabalSpecV3_8
 255
 256 enableMultidot :: CabalSpecVersion -> Bool
 257 enableMultidot version
 258   | version >= CabalSpecV2_4 = True
 259   | otherwise = False
 260
 261 --------------------------------------------------------------------------------
 262 -- Parse and printing utils
 263 --------------------------------------------------------------------------------
 264
 265 -- ** Cabal package globbing errors
 266
 267 data GlobSyntaxError
 268   = StarInDirectory
 269   | StarInFileName
 270   | StarInExtension
 271   | NoExtensionOnStar
 272   | EmptyGlob
 273   | LiteralFileNameGlobStar
 274   | VersionDoesNotSupportGlobStar
 275   | VersionDoesNotSupportGlob
 276   deriving (Eq, Show)
 277
 278 explainGlobSyntaxError :: FilePath -> GlobSyntaxError -> String
 279 explainGlobSyntaxError filepath StarInDirectory =
 280   "invalid file glob '"
 281     ++ filepath
 282     ++ "'. A wildcard '**' is only allowed as the final parent"
 283     ++ " directory. Stars must not otherwise appear in the parent"
 284     ++ " directories."
 285 explainGlobSyntaxError filepath StarInExtension =
 286   "invalid file glob '"
 287     ++ filepath
 288     ++ "'. Wildcards '*' are only allowed as the"
 289     ++ " file's base name, not in the file extension."
 290 explainGlobSyntaxError filepath StarInFileName =
 291   "invalid file glob '"
 292     ++ filepath
 293     ++ "'. Wildcards '*' may only totally replace the"
 294     ++ " file's base name, not only parts of it."
 295 explainGlobSyntaxError filepath NoExtensionOnStar =
 296   "invalid file glob '"
 297     ++ filepath
 298     ++ "'. If a wildcard '*' is used it must be with an file extension."
 299 explainGlobSyntaxError filepath LiteralFileNameGlobStar =
 300   "invalid file glob '"
 301     ++ filepath
 302     ++ "'. Prior to 'cabal-version: 3.8'"
 303     ++ " if a wildcard '**' is used as a parent directory, the"
 304     ++ " file's base name must be a wildcard '*'."
 305 explainGlobSyntaxError _ EmptyGlob =
 306   "invalid file glob. A glob cannot be the empty string."
 307 explainGlobSyntaxError filepath VersionDoesNotSupportGlobStar =
 308   "invalid file glob '"
 309     ++ filepath
 310     ++ "'. Using the double-star syntax requires 'cabal-version: 2.4'"
 311     ++ " or greater. Alternatively, for compatibility with earlier Cabal"
 312     ++ " versions, list the included directories explicitly."
 313 explainGlobSyntaxError filepath VersionDoesNotSupportGlob =
 314   "invalid file glob '"
 315     ++ filepath
 316     ++ "'. Using star wildcards requires 'cabal-version: >= 1.6'. "
 317     ++ "Alternatively if you require compatibility with earlier Cabal "
 318     ++ "versions then list all the files explicitly."
 319
 320 -- Note throughout that we use splitDirectories, not splitPath. On
 321 -- Posix, this makes no difference, but, because Windows accepts both
 322 -- slash and backslash as its path separators, if we left in the
 323 -- separators from the glob we might not end up properly normalised.
 324
 325 data GlobResult a
 326   = -- | The glob matched the value supplied.
 327     GlobMatch a
 328   | -- | The glob did not match the value supplied because the
 329     --   cabal-version is too low and the extensions on the file did
 330     --   not precisely match the glob's extensions, but rather the
 331     --   glob was a proper suffix of the file's extensions; i.e., if
 332     --   not for the low cabal-version, it would have matched.
 333     GlobWarnMultiDot a
 334   | -- | The glob couldn't match because the directory named doesn't
 335     --   exist. The directory will be as it appears in the glob (i.e.,
 336     --   relative to the directory passed to 'matchDirFileGlob', and,
 337     --   for 'data-files', relative to 'data-dir').
 338     GlobMissingDirectory a
 339   | -- | The glob matched a directory when we were looking for files only.
 340     -- It didn't match a file!
 341     --
 342     -- @since 3.12.0.0
 343     GlobMatchesDirectory a
 344   deriving (Show, Eq, Ord, Functor)
 345
 346 -- | Match files against a pre-parsed glob, starting in a directory.
 347 --
 348 -- The 'Version' argument must be the spec version of the package
 349 -- description being processed, as globs behave slightly differently
 350 -- in different spec versions.
 351 --
 352 -- The 'FilePath' argument is the directory that the glob is relative
 353 -- to. It must be a valid directory (and hence it can't be the empty
 354 -- string). The returned values will not include this prefix.
 355 runDirFileGlob
 356   :: Verbosity
 357   -> Maybe CabalSpecVersion
 358   -- ^ If the glob we are running should care about the cabal spec, and warnings such as 'GlobWarnMultiDot', then this should be the version.
 359   -- If you want to run a glob but don't care about any of the cabal-spec restrictions on globs, use 'Nothing'!
 360   -> FilePath
 361   -> Glob
 362   -> IO [GlobResult FilePath]
 363 runDirFileGlob verbosity mspec rawRoot pat = do
 364   -- The default data-dir is null. Our callers -should- be
 365   -- converting that to '.' themselves, but it's a certainty that
 366   -- some future call-site will forget and trigger a really
 367   -- hard-to-debug failure if we don't check for that here.
 368   when (null rawRoot) $
 369     warn verbosity $
 370       "Null dir passed to runDirFileGlob; interpreting it "
 371         ++ "as '.'. This is probably an internal error."
 372   let root = if null rawRoot then "." else rawRoot
 373   debug verbosity $ "Expanding glob '" ++ show (pretty pat) ++ "' in directory '" ++ root ++ "'."
 374   -- This function might be called from the project root with dir as
 375   -- ".". Walking the tree starting there involves going into .git/
 376   -- and dist-newstyle/, which is a lot of work for no reward, so
 377   -- extract the constant prefix from the pattern and start walking
 378   -- there, and only walk as much as we need to: recursively if **,
 379   -- the whole directory if *, and just the specific file if it's a
 380   -- literal.
 381   let
 382     (prefixSegments, variablePattern) = splitConstantPrefix pat
 383     joinedPrefix = joinPath prefixSegments
 384
 385     -- The glob matching function depends on whether we care about the cabal version or not
 386     doesGlobMatch :: GlobPieces -> String -> Maybe (GlobResult ())
 387     doesGlobMatch glob str = case mspec of
 388       Just spec -> checkNameMatches spec glob str
 389       Nothing -> if matchGlobPieces glob str then Just (GlobMatch ()) else Nothing
 390
 391     go (GlobFile glob) dir = do
 392       entries <- getDirectoryContents (root </> dir)
 393       catMaybes
 394         <$> mapM
 395           ( \s -> do
 396               -- When running a glob from a Cabal package description (i.e.
 397               -- when a cabal spec version is passed as an argument), we
 398               -- disallow matching a @GlobFile@ against a directory, preferring
 399               -- @GlobDir dir GlobDirTrailing@ to specify a directory match.
 400               isFile <- maybe (return True) (const $ doesFileExist (root </> dir </> s)) mspec
 401               let match = (dir </> s <$) <$> doesGlobMatch glob s
 402               return $
 403                 if isFile
 404                   then match
 405                   else case match of
 406                     Just (GlobMatch x) -> Just $ GlobMatchesDirectory x
 407                     Just (GlobWarnMultiDot x) -> Just $ GlobMatchesDirectory x
 408                     Just (GlobMatchesDirectory x) -> Just $ GlobMatchesDirectory x
 409                     Just (GlobMissingDirectory x) -> Just $ GlobMissingDirectory x -- this should never match, unless you are in a file-delete-heavy concurrent setting i guess
 410                     Nothing -> Nothing
 411           )
 412           entries
 413     go (GlobDirRecursive glob) dir = do
 414       entries <- getDirectoryContentsRecursive (root </> dir)
 415       return $
 416         mapMaybe
 417           ( \s -> do
 418               globMatch <- doesGlobMatch glob (takeFileName s)
 419               pure ((dir </> s) <$ globMatch)
 420           )
 421           entries
 422     go (GlobDir glob globPath) dir = do
 423       entries <- getDirectoryContents (root </> dir)
 424       subdirs <-
 425         filterM
 426           ( \subdir ->
 427               doesDirectoryExist
 428                 (root </> dir </> subdir)
 429           )
 430           $ filter (matchGlobPieces glob) entries
 431       concat <$> traverse (\subdir -> go globPath (dir </> subdir)) subdirs
 432     go GlobDirTrailing dir = return [GlobMatch dir]
 433
 434   directoryExists <- doesDirectoryExist (root </> joinedPrefix)
 435   if directoryExists
 436     then go variablePattern joinedPrefix
 437     else return [GlobMissingDirectory joinedPrefix]
 438   where
 439     -- \| Extract the (possibly null) constant prefix from the pattern.
 440     -- This has the property that, if @(pref, final) = splitConstantPrefix pat@,
 441     -- then @pat === foldr GlobDir final pref@.
 442     splitConstantPrefix :: Glob -> ([FilePath], Glob)
 443     splitConstantPrefix = unfoldr' step
 444       where
 445         step (GlobDir [Literal seg] pat') = Right (seg, pat')
 446         step pat' = Left pat'
 447
 448         unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r)
 449         unfoldr' f a = case f a of
 450           Left r -> ([], r)
 451           Right (b, a') -> case unfoldr' f a' of
 452             (bs, r) -> (b : bs, r)
 453
 454 -- | Is the root of this relative glob path a directory-recursive wildcard, e.g. @**/*.txt@ ?
 455 isRecursiveInRoot :: Glob -> Bool
 456 isRecursiveInRoot (GlobDirRecursive _) = True
 457 isRecursiveInRoot _ = False
 458
 459 -- | Check how the string matches the glob under this cabal version
 460 checkNameMatches :: CabalSpecVersion -> GlobPieces -> String -> Maybe (GlobResult ())
 461 checkNameMatches spec glob candidate
 462   -- Check if glob matches in its general form
 463   | matchGlobPieces glob candidate =
 464       -- if multidot is supported, then this is a clean match
 465       if enableMultidot spec
 466         then pure (GlobMatch ())
 467         else -- if not, issue a warning saying multidot is needed for the match
 468
 469           let (_, candidateExts) = splitExtensions $ takeFileName candidate
 470               extractExts :: GlobPieces -> Maybe String
 471               extractExts [] = Nothing
 472               extractExts [Literal lit]
 473                 -- Any literal terminating a glob, and which does have an extension,
 474                 -- returns that extension. Otherwise, recurse until Nothing is returned.
 475                 | let ext = takeExtensions lit
 476                 , ext /= "" =
 477                     Just ext
 478               extractExts (_ : x) = extractExts x
 479            in case extractExts glob of
 480                 Just exts
 481                   | exts == candidateExts ->
 482                       return (GlobMatch ())
 483                   | exts `isSuffixOf` candidateExts ->
 484                       return (GlobWarnMultiDot ())
 485                 _ -> return (GlobMatch ())
 486   | otherwise = empty
 487
 488 -- | How/does the glob match the given filepath, according to the cabal version?
 489 -- Since this is pure, we don't make a distinction between matching on
 490 -- directories or files (i.e. this function won't return 'GlobMatchesDirectory')
 491 fileGlobMatches :: CabalSpecVersion -> Glob -> FilePath -> Maybe (GlobResult ())
 492 fileGlobMatches version g path = go g (splitDirectories path)
 493   where
 494     go GlobDirTrailing [] = Just (GlobMatch ())
 495     go (GlobFile glob) [file] = checkNameMatches version glob file
 496     go (GlobDirRecursive glob) dirs
 497       | [] <- reverse dirs =
 498           Nothing -- @dir/**/x.txt@ should not match @dir/hello@
 499       | file : _ <- reverse dirs =
 500           checkNameMatches version glob file
 501     go (GlobDir glob globPath) (dir : dirs) = do
 502       _ <- checkNameMatches version glob dir -- we only care if dir segment matches
 503       go globPath dirs
 504     go _ _ = Nothing