Cabal/src/Distribution/Simple/Glob.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE RankNTypes #-}
   4
   5 -----------------------------------------------------------------------------
   6
   7 -- |
   8 -- Module      :  Distribution.Simple.Glob
   9 -- Copyright   :  Isaac Jones, Simon Marlow 2003-2004
  10 -- License     :  BSD3
  11 --                portions Copyright (c) 2007, Galois Inc.
  12 --
  13 -- Maintainer  :  cabal-devel@haskell.org
  14 -- Portability :  portable
  15 --
  16 -- Simple file globbing.
  17 module Distribution.Simple.Glob
  18   ( GlobSyntaxError (..)
  19   , GlobResult (..)
  20   , matchDirFileGlob
  21   , matchDirFileGlobWithDie
  22   , runDirFileGlob
  23   , fileGlobMatches
  24   , parseFileGlob
  25   , explainGlobSyntaxError
  26   , isRecursiveInRoot
  27   , Glob
  28   ) where
  29
  30 import Distribution.Compat.Prelude
  31 import Prelude ()
  32
  33 import Distribution.CabalSpecVersion
  34 import Distribution.Simple.Utils
  35 import Distribution.Verbosity
  36
  37 import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents)
  38 import System.FilePath (joinPath, splitDirectories, splitExtensions, takeFileName, (<.>), (</>))
  39
  40 import qualified Data.List.NonEmpty as NE
  41 import Distribution.Simple.Errors
  42
  43 -- Note throughout that we use splitDirectories, not splitPath. On
  44 -- Posix, this makes no difference, but, because Windows accepts both
  45 -- slash and backslash as its path separators, if we left in the
  46 -- separators from the glob we might not end up properly normalised.
  47
  48 data GlobResult a
  49   = -- | The glob matched the value supplied.
  50     GlobMatch a
  51   | -- | The glob did not match the value supplied because the
  52     --   cabal-version is too low and the extensions on the file did
  53     --   not precisely match the glob's extensions, but rather the
  54     --   glob was a proper suffix of the file's extensions; i.e., if
  55     --   not for the low cabal-version, it would have matched.
  56     GlobWarnMultiDot a
  57   | -- | The glob couldn't match because the directory named doesn't
  58     --   exist. The directory will be as it appears in the glob (i.e.,
  59     --   relative to the directory passed to 'matchDirFileGlob', and,
  60     --   for 'data-files', relative to 'data-dir').
  61     GlobMissingDirectory FilePath
  62   deriving (Show, Eq, Ord, Functor)
  63
  64 -- | Extract the matches from a list of 'GlobResult's.
  65 --
  66 -- Note: throws away the 'GlobMissingDirectory' results; chances are
  67 -- that you want to check for these and error out if any are present.
  68 globMatches :: [GlobResult a] -> [a]
  69 globMatches input = [a | GlobMatch a <- input]
  70
  71 data GlobSyntaxError
  72   = StarInDirectory
  73   | StarInFileName
  74   | StarInExtension
  75   | NoExtensionOnStar
  76   | EmptyGlob
  77   | LiteralFileNameGlobStar
  78   | VersionDoesNotSupportGlobStar
  79   | VersionDoesNotSupportGlob
  80   deriving (Eq, Show)
  81
  82 explainGlobSyntaxError :: FilePath -> GlobSyntaxError -> String
  83 explainGlobSyntaxError filepath StarInDirectory =
  84   "invalid file glob '"
  85     ++ filepath
  86     ++ "'. A wildcard '**' is only allowed as the final parent"
  87     ++ " directory. Stars must not otherwise appear in the parent"
  88     ++ " directories."
  89 explainGlobSyntaxError filepath StarInExtension =
  90   "invalid file glob '"
  91     ++ filepath
  92     ++ "'. Wildcards '*' are only allowed as the"
  93     ++ " file's base name, not in the file extension."
  94 explainGlobSyntaxError filepath StarInFileName =
  95   "invalid file glob '"
  96     ++ filepath
  97     ++ "'. Wildcards '*' may only totally replace the"
  98     ++ " file's base name, not only parts of it."
  99 explainGlobSyntaxError filepath NoExtensionOnStar =
 100   "invalid file glob '"
 101     ++ filepath
 102     ++ "'. If a wildcard '*' is used it must be with an file extension."
 103 explainGlobSyntaxError filepath LiteralFileNameGlobStar =
 104   "invalid file glob '"
 105     ++ filepath
 106     ++ "'. Prior to 'cabal-version: 3.8'"
 107     ++ " if a wildcard '**' is used as a parent directory, the"
 108     ++ " file's base name must be a wildcard '*'."
 109 explainGlobSyntaxError _ EmptyGlob =
 110   "invalid file glob. A glob cannot be the empty string."
 111 explainGlobSyntaxError filepath VersionDoesNotSupportGlobStar =
 112   "invalid file glob '"
 113     ++ filepath
 114     ++ "'. Using the double-star syntax requires 'cabal-version: 2.4'"
 115     ++ " or greater. Alternatively, for compatibility with earlier Cabal"
 116     ++ " versions, list the included directories explicitly."
 117 explainGlobSyntaxError filepath VersionDoesNotSupportGlob =
 118   "invalid file glob '"
 119     ++ filepath
 120     ++ "'. Using star wildcards requires 'cabal-version: >= 1.6'. "
 121     ++ "Alternatively if you require compatibility with earlier Cabal "
 122     ++ "versions then list all the files explicitly."
 123
 124 data IsRecursive = Recursive | NonRecursive deriving (Eq)
 125
 126 data MultiDot = MultiDotDisabled | MultiDotEnabled
 127
 128 data Glob
 129   = -- | A single subdirectory component + remainder.
 130     GlobStem FilePath Glob
 131   | GlobFinal GlobFinal
 132
 133 data GlobFinal
 134   = -- | First argument: Is this a @**/*.ext@ pattern?
 135     --   Second argument: should we match against the exact extensions, or accept a suffix?
 136     --   Third argument: the extensions to accept.
 137     FinalMatch IsRecursive MultiDot String
 138   | -- | Literal file name.
 139     FinalLit IsRecursive FilePath
 140
 141 reconstructGlob :: Glob -> FilePath
 142 reconstructGlob (GlobStem dir glob) =
 143   dir </> reconstructGlob glob
 144 reconstructGlob (GlobFinal final) = case final of
 145   FinalMatch Recursive _ exts -> "**" </> "*" <.> exts
 146   FinalMatch NonRecursive _ exts -> "*" <.> exts
 147   FinalLit Recursive path -> "**" </> path
 148   FinalLit NonRecursive path -> path
 149
 150 -- | Returns 'Nothing' if the glob didn't match at all, or 'Just' the
 151 --   result if the glob matched (or would have matched with a higher
 152 --   cabal-version).
 153 fileGlobMatches :: Glob -> FilePath -> Maybe (GlobResult FilePath)
 154 fileGlobMatches pat candidate = do
 155   match <- fileGlobMatchesSegments pat (splitDirectories candidate)
 156   return (candidate <$ match)
 157
 158 fileGlobMatchesSegments :: Glob -> [FilePath] -> Maybe (GlobResult ())
 159 fileGlobMatchesSegments _ [] = Nothing
 160 fileGlobMatchesSegments pat (seg : segs) = case pat of
 161   GlobStem dir pat' -> do
 162     guard (dir == seg)
 163     fileGlobMatchesSegments pat' segs
 164   GlobFinal final -> case final of
 165     FinalMatch Recursive multidot ext -> do
 166       let (candidateBase, candidateExts) = splitExtensions (NE.last $ seg :| segs)
 167       guard (not (null candidateBase))
 168       checkExt multidot ext candidateExts
 169     FinalMatch NonRecursive multidot ext -> do
 170       let (candidateBase, candidateExts) = splitExtensions seg
 171       guard (null segs && not (null candidateBase))
 172       checkExt multidot ext candidateExts
 173     FinalLit isRecursive filename -> do
 174       guard ((isRecursive == Recursive || null segs) && filename == seg)
 175       return (GlobMatch ())
 176
 177 checkExt
 178   :: MultiDot
 179   -> String
 180   -- ^ The pattern's extension
 181   -> String
 182   -- ^ The candidate file's extension
 183   -> Maybe (GlobResult ())
 184 checkExt multidot ext candidate
 185   | ext == candidate = Just (GlobMatch ())
 186   | ext `isSuffixOf` candidate = case multidot of
 187       MultiDotDisabled -> Just (GlobWarnMultiDot ())
 188       MultiDotEnabled -> Just (GlobMatch ())
 189   | otherwise = Nothing
 190
 191 parseFileGlob :: CabalSpecVersion -> FilePath -> Either GlobSyntaxError Glob
 192 parseFileGlob version filepath = case reverse (splitDirectories filepath) of
 193   [] ->
 194     Left EmptyGlob
 195   (filename : "**" : segments)
 196     | allowGlobStar -> do
 197         finalSegment <- case splitExtensions filename of
 198           ("*", ext)
 199             | '*' `elem` ext -> Left StarInExtension
 200             | null ext -> Left NoExtensionOnStar
 201             | otherwise -> Right (FinalMatch Recursive multidot ext)
 202           _ ->
 203             if allowLiteralFilenameGlobStar
 204               then Right (FinalLit Recursive filename)
 205               else Left LiteralFileNameGlobStar
 206         foldM addStem (GlobFinal finalSegment) segments
 207     | otherwise -> Left VersionDoesNotSupportGlobStar
 208   (filename : segments) -> do
 209     pat <- case splitExtensions filename of
 210       ("*", ext)
 211         | not allowGlob -> Left VersionDoesNotSupportGlob
 212         | '*' `elem` ext -> Left StarInExtension
 213         | null ext -> Left NoExtensionOnStar
 214         | otherwise -> Right (FinalMatch NonRecursive multidot ext)
 215       (_, ext)
 216         | '*' `elem` ext -> Left StarInExtension
 217         | '*' `elem` filename -> Left StarInFileName
 218         | otherwise -> Right (FinalLit NonRecursive filename)
 219     foldM addStem (GlobFinal pat) segments
 220   where
 221     allowGlob = version >= CabalSpecV1_6
 222     allowGlobStar = version >= CabalSpecV2_4
 223     addStem pat seg
 224       | '*' `elem` seg = Left StarInDirectory
 225       | otherwise = Right (GlobStem seg pat)
 226     multidot
 227       | version >= CabalSpecV2_4 = MultiDotEnabled
 228       | otherwise = MultiDotDisabled
 229     allowLiteralFilenameGlobStar = version >= CabalSpecV3_8
 230
 231 -- | This will 'die'' when the glob matches no files, or if the glob
 232 -- refers to a missing directory, or if the glob fails to parse.
 233 --
 234 -- The 'Version' argument must be the spec version of the package
 235 -- description being processed, as globs behave slightly differently
 236 -- in different spec versions.
 237 --
 238 -- The first 'FilePath' argument is the directory that the glob is
 239 -- relative to. It must be a valid directory (and hence it can't be
 240 -- the empty string). The returned values will not include this
 241 -- prefix.
 242 --
 243 -- The second 'FilePath' is the glob itself.
 244 matchDirFileGlob :: Verbosity -> CabalSpecVersion -> FilePath -> FilePath -> IO [FilePath]
 245 matchDirFileGlob v = matchDirFileGlobWithDie v dieWithException
 246
 247 -- | Like 'matchDirFileGlob' but with customizable 'die'
 248 --
 249 -- @since 3.6.0.0
 250 matchDirFileGlobWithDie :: Verbosity -> (Verbosity -> CabalException -> IO [FilePath]) -> CabalSpecVersion -> FilePath -> FilePath -> IO [FilePath]
 251 matchDirFileGlobWithDie verbosity rip version dir filepath = case parseFileGlob version filepath of
 252   Left err -> rip verbosity $ MatchDirFileGlob (explainGlobSyntaxError filepath err)
 253   Right glob -> do
 254     results <- runDirFileGlob verbosity dir glob
 255     let missingDirectories =
 256           [missingDir | GlobMissingDirectory missingDir <- results]
 257         matches = globMatches results
 258
 259     let errors :: [String]
 260         errors =
 261           [ "filepath wildcard '"
 262             ++ filepath
 263             ++ "' refers to the directory"
 264             ++ " '"
 265             ++ missingDir
 266             ++ "', which does not exist or is not a directory."
 267           | missingDir <- missingDirectories
 268           ]
 269             ++ [ "filepath wildcard '" ++ filepath ++ "' does not match any files."
 270                | null matches
 271                ]
 272
 273     if null errors
 274       then return matches
 275       else rip verbosity $ MatchDirFileGlobErrors errors
 276
 277 -- | Match files against a pre-parsed glob, starting in a directory.
 278 --
 279 -- The 'Version' argument must be the spec version of the package
 280 -- description being processed, as globs behave slightly differently
 281 -- in different spec versions.
 282 --
 283 -- The 'FilePath' argument is the directory that the glob is relative
 284 -- to. It must be a valid directory (and hence it can't be the empty
 285 -- string). The returned values will not include this prefix.
 286 runDirFileGlob :: Verbosity -> FilePath -> Glob -> IO [GlobResult FilePath]
 287 runDirFileGlob verbosity rawDir pat = do
 288   -- The default data-dir is null. Our callers -should- be
 289   -- converting that to '.' themselves, but it's a certainty that
 290   -- some future call-site will forget and trigger a really
 291   -- hard-to-debug failure if we don't check for that here.
 292   when (null rawDir) $
 293     warn verbosity $
 294       "Null dir passed to runDirFileGlob; interpreting it "
 295         ++ "as '.'. This is probably an internal error."
 296   let dir = if null rawDir then "." else rawDir
 297   debug verbosity $ "Expanding glob '" ++ reconstructGlob pat ++ "' in directory '" ++ dir ++ "'."
 298   -- This function might be called from the project root with dir as
 299   -- ".". Walking the tree starting there involves going into .git/
 300   -- and dist-newstyle/, which is a lot of work for no reward, so
 301   -- extract the constant prefix from the pattern and start walking
 302   -- there, and only walk as much as we need to: recursively if **,
 303   -- the whole directory if *, and just the specific file if it's a
 304   -- literal.
 305   let (prefixSegments, final) = splitConstantPrefix pat
 306       joinedPrefix = joinPath prefixSegments
 307   case final of
 308     FinalMatch recursive multidot exts -> do
 309       let prefix = dir </> joinedPrefix
 310       directoryExists <- doesDirectoryExist prefix
 311       if directoryExists
 312         then do
 313           candidates <- case recursive of
 314             Recursive -> getDirectoryContentsRecursive prefix
 315             NonRecursive -> filterM (doesFileExist . (prefix </>)) =<< getDirectoryContents prefix
 316           let checkName candidate = do
 317                 let (candidateBase, candidateExts) = splitExtensions $ takeFileName candidate
 318                 guard (not (null candidateBase))
 319                 match <- checkExt multidot exts candidateExts
 320                 return (joinedPrefix </> candidate <$ match)
 321           return $ mapMaybe checkName candidates
 322         else return [GlobMissingDirectory joinedPrefix]
 323     FinalLit Recursive fn -> do
 324       let prefix = dir </> joinedPrefix
 325       directoryExists <- doesDirectoryExist prefix
 326       if directoryExists
 327         then do
 328           candidates <- getDirectoryContentsRecursive prefix
 329           let checkName candidate
 330                 | takeFileName candidate == fn = Just $ GlobMatch (joinedPrefix </> candidate)
 331                 | otherwise = Nothing
 332           return $ mapMaybe checkName candidates
 333         else return [GlobMissingDirectory joinedPrefix]
 334     FinalLit NonRecursive fn -> do
 335       exists <- doesFileExist (dir </> joinedPrefix </> fn)
 336       return [GlobMatch (joinedPrefix </> fn) | exists]
 337
 338 unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r)
 339 unfoldr' f a = case f a of
 340   Left r -> ([], r)
 341   Right (b, a') -> case unfoldr' f a' of
 342     (bs, r) -> (b : bs, r)
 343
 344 -- | Extract the (possibly null) constant prefix from the pattern.
 345 -- This has the property that, if @(pref, final) = splitConstantPrefix pat@,
 346 -- then @pat === foldr GlobStem (GlobFinal final) pref@.
 347 splitConstantPrefix :: Glob -> ([FilePath], GlobFinal)
 348 splitConstantPrefix = unfoldr' step
 349   where
 350     step (GlobStem seg pat) = Right (seg, pat)
 351     step (GlobFinal pat) = Left pat
 352
 353 isRecursiveInRoot :: Glob -> Bool
 354 isRecursiveInRoot (GlobFinal (FinalMatch Recursive _ _)) = True
 355 isRecursiveInRoot _ = False