Commit 2d569609 authored by Duncan Coutts's avatar Duncan Coutts Committed by Mikhail Glushenkov
Browse files

Extend file globs and file glob monitors

File globs can now be absolute, e.g. starting with / or c:\
Also allow homedir relative, ie ~/

Globs can also have a trailing slash, in which case they only match
directories, not files.

Previously whether globs could match dirs was not totally consistent.
The matchFileGlob would match dirs, but the file monitor globs would
not. The file monitor globs can now match dirs (or with a trailing
slash, only match dirs). File monitors now also detect changes in the
file type, ie switching from file to dir or the other way around.

The file monitor are now pretty consistent between single file monitors
and globs monitors. They now have equivalent capabilities and share
code. For a single file or for a glob we can now control what we
monitor if the path is a file or a dir. In both cases we can monitor
mere existence, non-existence or modification time. For files we can
additionally monitor content hash.

File monitors now also detect changes in the file type, ie switching
from file to dir or the other way around.

New tests cover all these new file monitor cases. There are also new
tests for glob syntax, covering printing/parsing round trips.

(cherry picked from commit f6c1e71c)
parent a6526403
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE CPP, DeriveGeneric #-}
--TODO: [code cleanup] plausibly much of this module should be merged with
-- similar functionality in Cabal.
module Distribution.Client.Glob
( GlobAtom(..)
, Glob (..)
, globMatches
( FilePathGlob(..)
, FilePathRoot(..)
, FilePathGlobRel(..)
, Glob
, GlobPiece(..)
, matchFileGlob
, matchFileGlobRel
, matchGlob
, isTrivialFilePathGlob
, getFilePathRootDirectory
) where
import Data.List (stripPrefix)
import Control.Monad (liftM2)
import Distribution.Compat.Binary
import GHC.Generics (Generic)
import Data.Char (toUpper)
import Data.List (stripPrefix)
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Control.Monad
import Distribution.Compat.Binary
import GHC.Generics (Generic)
import Distribution.Text
import Distribution.Compat.ReadP
import Distribution.Text
import Distribution.Compat.ReadP (ReadP, (<++), (+++))
import qualified Distribution.Compat.ReadP as Parse
import qualified Text.PrettyPrint as Disp
import System.FilePath
import System.Directory
-- | A piece of a globbing pattern
data GlobAtom = WildCard
| Literal String
| Union [Glob]
-- | A file path specified by globbing
--
data FilePathGlob = FilePathGlob FilePathRoot FilePathGlobRel
deriving (Eq, Show, Generic)
instance Binary GlobAtom
data FilePathGlobRel
= GlobDir !Glob !FilePathGlobRel
| GlobFile !Glob
| GlobDirTrailing -- ^ trailing dir, a glob ending in @/@
deriving (Eq, Show, Generic)
-- | A single directory or file component of a globbed path
newtype Glob = Glob [GlobAtom]
type Glob = [GlobPiece]
-- | A piece of a globbing pattern
data GlobPiece = WildCard
| Literal String
| Union [Glob]
deriving (Eq, Show, Generic)
instance Binary Glob
data FilePathRoot
= FilePathRelative
| FilePathUnixRoot
| FilePathWinDrive Char
| FilePathHomeDir
deriving (Eq, Show, Generic)
instance Binary FilePathGlob
instance Binary FilePathRoot
instance Binary FilePathGlobRel
instance Binary GlobPiece
-- | Check if a 'FilePathGlob' doesn't actually make use of any globbing and
-- is in fact equivalent to a non-glob 'FilePath'.
--
-- If it is trivial in this sense then the result is the equivalent constant
-- 'FilePath'. On the other hand if it is not trivial (so could in principle
-- match more than one file) then the result is @Nothing@.
--
isTrivialFilePathGlob :: FilePathGlob -> Maybe FilePath
isTrivialFilePathGlob (FilePathGlob root pathglob) =
case root of
FilePathRelative -> go [] pathglob
FilePathUnixRoot -> go ["/"] pathglob
FilePathWinDrive drive -> go [drive:":"] pathglob
FilePathHomeDir -> Nothing
where
go paths (GlobDir [Literal path] globs) = go (path:paths) globs
go paths (GlobFile [Literal path]) = Just (joinPath (reverse (path:paths)))
go paths GlobDirTrailing = Just (addTrailingPathSeparator
(joinPath (reverse paths)))
go _ _ = Nothing
-- | Get the 'FilePath' corresponding to a 'FilePathRoot'.
--
-- The 'FilePath' argument is required to supply the path for the
-- 'FilePathRelative' case.
--
getFilePathRootDirectory :: FilePathRoot
-> FilePath -- ^ root for relative paths
-> IO FilePath
getFilePathRootDirectory FilePathRelative root = return root
getFilePathRootDirectory FilePathUnixRoot _ = return "/"
getFilePathRootDirectory (FilePathWinDrive drive) _ = return (drive:":")
getFilePathRootDirectory FilePathHomeDir _ = getHomeDirectory
------------------------------------------------------------------------------
-- Matching
--
-- | Match a 'FilePathGlob' against the file system, starting from a given
-- root directory for relative paths. The results of relative globs are
-- relative to the given root. Matches for absolute globs are absolute.
--
matchFileGlob :: FilePath -> FilePathGlob -> IO [FilePath]
matchFileGlob relroot (FilePathGlob globroot glob) = do
root <- getFilePathRootDirectory globroot relroot
matches <- matchFileGlobRel root glob
case globroot of
FilePathRelative -> return matches
_ -> return (map (root </>) matches)
-- | Match a 'FilePathGlobRel' against the file system, starting from a
-- given root directory. The results are all relative to the given root.
--
matchFileGlobRel :: FilePath -> FilePathGlobRel -> IO [FilePath]
matchFileGlobRel root glob0 = go glob0 ""
where
go (GlobFile glob) dir = do
entries <- getDirectoryContents (root </> dir)
let files = filter (matchGlob glob) entries
return (map (dir </>) files)
go (GlobDir glob globPath) dir = do
entries <- getDirectoryContents (root </> dir)
subdirs <- filterM (\subdir -> doesDirectoryExist
(root </> dir </> subdir))
$ filter (matchGlob glob) entries
concat <$> mapM (\subdir -> go globPath (dir </> subdir)) subdirs
go GlobDirTrailing dir = return [dir]
-- | Test whether a file path component matches a globbing pattern
-- | Match a globbing pattern against a file path component
--
globMatches :: Glob -> String -> Bool
globMatches (Glob atoms) = goStart atoms
matchGlob :: Glob -> String -> Bool
matchGlob = goStart
where
-- From the man page, glob(7):
-- "If a filename starts with a '.', this character must be
-- matched explicitly."
go, goStart :: [GlobAtom] -> String -> Bool
go, goStart :: [GlobPiece] -> String -> Bool
goStart (WildCard:_) ('.':_) = False
goStart (Union globs:rest) cs = any (\(Glob glob) ->
goStart (glob ++ rest) cs) globs
goStart (Union globs:rest) cs = any (\glob -> goStart (glob ++ rest) cs)
globs
goStart rest cs = go rest cs
go [] "" = True
......@@ -54,53 +161,116 @@ globMatches (Glob atoms) = goStart atoms
| otherwise = False
go [WildCard] "" = True
go (WildCard:rest) (c:cs) = go rest (c:cs) || go (WildCard:rest) cs
go (Union globs:rest) cs = any (\(Glob glob) ->
go (glob ++ rest) cs) globs
go (Union globs:rest) cs = any (\glob -> go (glob ++ rest) cs) globs
go [] (_:_) = False
go (_:_) "" = False
instance Text Glob where
disp (Glob atoms) = Disp.hcat (map dispAtom atoms)
where
dispAtom WildCard = Disp.char '*'
dispAtom (Literal str) = Disp.text (escape str)
dispAtom (Union globs) = Disp.braces
(Disp.hcat (Disp.punctuate (Disp.char ',')
(map disp globs)))
escape [] = []
escape (c:cs)
| isGlobEscapedChar c = '\\' : c : escape cs
| otherwise = c : escape cs
parse = Glob `fmap` many1 globAtom
------------------------------------------------------------------------------
-- Parsing & printing
--
instance Text FilePathGlob where
disp (FilePathGlob root pathglob) = disp root Disp.<> disp pathglob
parse =
parse >>= \root ->
(FilePathGlob root <$> parse)
<++ (when (root == FilePathRelative) Parse.pfail >>
return (FilePathGlob root GlobDirTrailing))
instance Text FilePathRoot where
disp FilePathRelative = Disp.empty
disp FilePathUnixRoot = Disp.char '/'
disp (FilePathWinDrive c) = Disp.char c
Disp.<> Disp.char ':'
Disp.<> Disp.char '\\'
disp FilePathHomeDir = Disp.char '~'
Disp.<> Disp.char '/'
parse =
( (Parse.char '/' >> return FilePathUnixRoot)
+++ (Parse.char '~' >> Parse.char '/' >> return FilePathHomeDir)
+++ (do drive <- Parse.satisfy (\c -> (c >= 'a' && c <= 'z')
|| (c >= 'A' && c <= 'Z'))
_ <- Parse.char ':'
_ <- Parse.char '/' +++ Parse.char '\\'
return (FilePathWinDrive (toUpper drive)))
)
<++ return FilePathRelative
instance Text FilePathGlobRel where
disp (GlobDir glob pathglob) = dispGlob glob
Disp.<> Disp.char '/'
Disp.<> disp pathglob
disp (GlobFile glob) = dispGlob glob
disp GlobDirTrailing = Disp.empty
parse = parsePath
where
globAtom :: ReadP r GlobAtom
globAtom = literal +++ wildcard +++ union
parsePath :: ReadP r FilePathGlobRel
parsePath =
parseGlob >>= \globpieces ->
asDir globpieces
<++ asTDir globpieces
<++ asFile globpieces
asDir glob = do dirSep
globs <- parsePath
return (GlobDir glob globs)
asTDir glob = do dirSep
return (GlobDir glob GlobDirTrailing)
asFile glob = return (GlobFile glob)
dirSep = (Parse.char '/' >> return ())
+++ (do _ <- Parse.char '\\'
-- check this isn't an escape code
following <- Parse.look
case following of
(c:_) | isGlobEscapedChar c -> Parse.pfail
_ -> return ())
dispGlob :: Glob -> Disp.Doc
dispGlob = Disp.hcat . map dispPiece
where
dispPiece WildCard = Disp.char '*'
dispPiece (Literal str) = Disp.text (escape str)
dispPiece (Union globs) = Disp.braces
(Disp.hcat (Disp.punctuate
(Disp.char ',')
(map dispGlob globs)))
escape [] = []
escape (c:cs)
| isGlobEscapedChar c = '\\' : c : escape cs
| otherwise = c : escape cs
parseGlob :: ReadP r Glob
parseGlob = Parse.many1 parsePiece
where
parsePiece = literal +++ wildcard +++ union
wildcard = Parse.char '*' >> return WildCard
union = Parse.between (Parse.char '{') (Parse.char '}') $
fmap Union (Parse.sepBy1 parseGlob (Parse.char ','))
wildcard = char '*' >> return WildCard
literal = Literal `fmap` litchars1
union = between (char '{') (char '}')
(fmap (Union . map Glob) $ sepBy1 (many1 globAtom) (char ','))
litchar = normal +++ escape
literal = Literal `fmap` many1'
where
litchar = normal +++ escape
normal = satisfy (not . isGlobEscapedChar)
escape = char '\\' >> satisfy isGlobEscapedChar
normal = Parse.satisfy (\c -> not (isGlobEscapedChar c)
&& c /= '/' && c /= '\\')
escape = Parse.char '\\' >> Parse.satisfy isGlobEscapedChar
many1' :: ReadP r [Char]
many1' = liftM2 (:) litchar many'
litchars1 :: ReadP r [Char]
litchars1 = liftM2 (:) litchar litchars
many' :: ReadP r [Char]
many' = many1' <++ return []
litchars :: ReadP r [Char]
litchars = litchars1 <++ return []
isGlobEscapedChar :: Char -> Bool
isGlobEscapedChar '*' = True
isGlobEscapedChar '{' = True
isGlobEscapedChar '}' = True
isGlobEscapedChar ',' = True
isGlobEscapedChar '\\' = True
isGlobEscapedChar '/' = True
isGlobEscapedChar _ = False
\ No newline at end of file
isGlobEscapedChar _ = False
......@@ -519,7 +519,7 @@ updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild}
srcdir timestamp pkg pkgBuildStatus
allSrcFiles buildSuccess =
updateFileMonitor pkgFileMonitorBuild srcdir (Just timestamp)
(map MonitorFileHashed allSrcFiles)
(map monitorFileHashed allSrcFiles)
buildComponents' buildSuccess
where
(_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg
......
......@@ -37,14 +37,12 @@ module Distribution.Client.ProjectConfig (
import Distribution.Client.ProjectConfig.Types
import Distribution.Client.ProjectConfig.Legacy
import Distribution.Client.RebuildMonad
import Distribution.Client.FileMonitor
import Distribution.Client.Glob
( isTrivialFilePathGlob )
import Distribution.Client.Types
import Distribution.Client.DistDirLayout
( CabalDirLayout(..) )
import Distribution.Client.Glob
( Glob(..), GlobAtom(..) )
import Distribution.Client.GlobalFlags
( RepoContext(..), withRepoContext' )
import Distribution.Client.BuildReports.Types
......@@ -353,10 +351,10 @@ readProjectLocalConfig verbosity projectRootDir = do
usesExplicitProjectRoot <- liftIO $ doesFileExist projectFile
if usesExplicitProjectRoot
then do
monitorFiles [MonitorFileHashed projectFile]
monitorFiles [monitorFileHashed projectFile]
liftIO readProjectFile
else do
monitorFiles [MonitorNonExistentFile projectFile]
monitorFiles [monitorNonExistentFile projectFile]
return defaultImplicitProjectConfig
where
......@@ -385,9 +383,9 @@ readProjectLocalExtraConfig :: Verbosity -> FilePath -> Rebuild ProjectConfig
readProjectLocalExtraConfig verbosity projectRootDir = do
hasExtraConfig <- liftIO $ doesFileExist projectExtraConfigFile
if hasExtraConfig
then do monitorFiles [MonitorFileHashed projectExtraConfigFile]
then do monitorFiles [monitorFileHashed projectExtraConfigFile]
liftIO readProjectExtraConfigFile
else do monitorFiles [MonitorNonExistentFile projectExtraConfigFile]
else do monitorFiles [monitorNonExistentFile projectExtraConfigFile]
return mempty
where
projectExtraConfigFile = projectRootDir </> "cabal.project.extra"
......@@ -442,7 +440,7 @@ readGlobalConfig :: Verbosity -> Rebuild ProjectConfig
readGlobalConfig verbosity = do
config <- liftIO (loadConfig verbosity mempty)
configFile <- liftIO defaultConfigFile
monitorFiles [MonitorFileHashed configFile]
monitorFiles [monitorFileHashed configFile]
return (convertLegacyGlobalConfig config)
--TODO: do this properly, there's several possible locations
-- and env vars, and flags for selecting the global config
......@@ -642,8 +640,9 @@ findProjectPackages projectRootDir ProjectConfig{..} = do
globStarDotCabal :: FilePath -> FilePathGlob
globStarDotCabal =
foldr (\dirpart -> GlobDir (Glob [Literal dirpart]))
(GlobFile (Glob [WildCard, Literal ".cabal"]))
FilePathGlob FilePathRelative
. foldr (\dirpart -> GlobDir [Literal dirpart])
(GlobFile [WildCard, Literal ".cabal"])
. splitDirectories
......
......@@ -733,7 +733,7 @@ getInstalledPackages :: Verbosity
-> PackageDBStack
-> Rebuild InstalledPackageIndex
getInstalledPackages verbosity compiler progdb platform packagedbs = do
monitorFiles . map MonitorFile
monitorFiles . map monitorFileOrDirectory
=<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles
verbosity compiler
packagedbs progdb platform)
......@@ -746,7 +746,7 @@ getPackageDBContents :: Verbosity
-> PackageDB
-> Rebuild InstalledPackageIndex
getPackageDBContents verbosity compiler progdb platform packagedb = do
monitorFiles . map MonitorFile
monitorFiles . map monitorFileOrDirectory
=<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles
verbosity compiler
[packagedb] progdb platform)
......@@ -765,7 +765,7 @@ getSourcePackages verbosity withRepoCtx = do
sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoctx
return (sourcePkgDb, repoContextRepos repoctx)
monitorFiles . map MonitorFile
monitorFiles . map monitorFile
. IndexUtils.getSourcePackagesMonitorFiles
$ repos
return sourcePkgDb
......@@ -785,7 +785,7 @@ createPackageDBIfMissing verbosity compiler progdb packageDbs =
recreateDirectory :: Verbosity -> Bool -> FilePath -> Rebuild ()
recreateDirectory verbosity createParents dir = do
liftIO $ createDirectoryIfMissingVerbose verbosity createParents dir
monitorFiles [MonitorFile dir]
monitorFiles [monitorDirectoryExistence dir]
-- | Get the 'HashValue' for all the source packages where we use hashes,
......@@ -830,7 +830,7 @@ getPackageSourceHashes verbosity withRepoCtx installPlan = do
| (pkg, srcloc) <- newlyDownloaded ++ alreadyDownloaded
, tarball <- maybeToList (tarballFileLocation srcloc) ]
monitorFiles [ MonitorFile tarball | (_pkgid, tarball) <- pkgsTarballs ]
monitorFiles [ monitorFile tarball | (_pkgid, tarball) <- pkgsTarballs ]
liftM Map.fromList $ liftIO $
sequence
......
......@@ -16,9 +16,21 @@ module Distribution.Client.RebuildMonad (
-- * Setting up file monitoring
monitorFiles,
MonitorFilePath(..),
MonitorFilePath,
monitorFile,
monitorFileHashed,
monitorNonExistentFile,
monitorDirectory,
monitorDirectoryExistence,
monitorFileOrDirectory,
monitorFileSearchPath,
monitorFileHashedSearchPath,
-- ** Monitoring file globs
monitorFileGlob,
FilePathGlob(..),
FilePathRoot(..),
FilePathGlobRel(..),
GlobPiece(..),
-- * Using a file monitor
FileMonitor(..),
......@@ -29,8 +41,9 @@ module Distribution.Client.RebuildMonad (
matchFileGlob,
) where
import Distribution.Client.FileMonitor hiding (matchFileGlob)
import qualified Distribution.Client.FileMonitor as FileMonitor (matchFileGlob)
import Distribution.Client.FileMonitor
import Distribution.Client.Glob hiding (matchFileGlob)
import qualified Distribution.Client.Glob as Glob (matchFileGlob)
import Distribution.Simple.Utils (debug)
import Distribution.Verbosity (Verbosity)
......@@ -117,6 +130,6 @@ rerunIfChanged verbosity rootDir monitor key action = do
--
matchFileGlob :: FilePath -> FilePathGlob -> Rebuild [FilePath]
matchFileGlob root glob = do
monitorFiles [MonitorFileGlob glob]
liftIO $ FileMonitor.matchFileGlob root glob
monitorFiles [monitorFileGlob glob]
liftIO $ Glob.matchFileGlob root glob
......@@ -286,6 +286,7 @@ Test-Suite unit-tests
UnitTests.Distribution.Client.Dependency.Modular.Solver
UnitTests.Distribution.Client.Dependency.Modular.DSL
UnitTests.Distribution.Client.FileMonitor
UnitTests.Distribution.Client.Glob
UnitTests.Distribution.Client.GZipUtils
UnitTests.Distribution.Client.Sandbox
UnitTests.Distribution.Client.Sandbox.Timestamp
......
......@@ -18,6 +18,7 @@ import qualified UnitTests.Distribution.Client.Compat.Time
import qualified UnitTests.Distribution.Client.Dependency.Modular.PSQ
import qualified UnitTests.Distribution.Client.Dependency.Modular.Solver
import qualified UnitTests.Distribution.Client.FileMonitor
import qualified UnitTests.Distribution.Client.Glob
import qualified UnitTests.Distribution.Client.GZipUtils
import qualified UnitTests.Distribution.Client.Sandbox
import qualified UnitTests.Distribution.Client.Sandbox.Timestamp
......@@ -45,6 +46,8 @@ tests mtimeChangeCalibrated =
UnitTests.Distribution.Client.Dependency.Modular.Solver.tests
, testGroup "UnitTests.Distribution.Client.FileMonitor" $
UnitTests.Distribution.Client.FileMonitor.tests mtimeChange
, testGroup "UnitTests.Distribution.Client.Glob"
UnitTests.Distribution.Client.Glob.tests
, testGroup "Distribution.Client.GZipUtils"
UnitTests.Distribution.Client.GZipUtils.tests
, testGroup "Distribution.Client.Sandbox"
......
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module UnitTests.Distribution.Client.Glob (tests) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Data.Char
import Data.List
import Distribution.Text (display, parse, simpleParse)
import Distribution.Compat.ReadP
import Distribution.Client.Glob
import UnitTests.Distribution.Client.ArbitraryInstances
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Tasty.HUnit
import Control.Exception
tests :: [TestTree]
tests =
[ testProperty "print/parse roundtrip" prop_roundtrip_printparse
, testCase "parse examples" testParseCases
]
--TODO: [nice to have] tests for trivial globs, tests for matching,
-- tests for windows style file paths
prop_roundtrip_printparse :: FilePathGlob -> Bool
prop_roundtrip_printparse pathglob =
-- can't use simpleParse because it mis-handles trailing spaces
case [ x | (x, []) <- readP_to_S parse (display pathglob) ] of
xs@(_:_) -> last xs == pathglob
_ -> False
-- first run, where we don't even call updateMonitor
testParseCases :: Assertion
testParseCases = do
FilePathGlob FilePathUnixRoot GlobDirTrailing <- testparse "/"
FilePathGlob FilePathHomeDir GlobDirTrailing <- testparse "~/"
FilePathGlob (FilePathWinDrive 'A') GlobDirTrailing <- testparse "A:/"
FilePathGlob (FilePathWinDrive 'Z') GlobDirTrailing <- testparse "z:/"
FilePathGlob (FilePathWinDrive 'C') GlobDirTrailing <- testparse "C:\\"
FilePathGlob FilePathRelative (GlobFile [Literal "_:"]) <- testparse "_:"
FilePathGlob FilePathRelative
(GlobFile [Literal "."]) <- testparse "."
FilePathGlob FilePathRelative
(GlobFile [Literal "~"]) <- testparse "~"
FilePathGlob FilePathRelative
(GlobDir [Literal "."] GlobDirTrailing) <- testparse "./"
FilePathGlob FilePathRelative
(GlobFile [Literal "foo"]) <- testparse "foo"
FilePathGlob FilePathRelative
(GlobDir [Literal "foo"]
(GlobFile [Literal "bar"])) <- testparse "foo/bar"
FilePathGlob FilePathRelative
(GlobDir [Literal "foo"]
(GlobDir [Literal "bar"] GlobDirTrailing)) <- testparse "foo/bar/"
FilePathGlob FilePathUnixRoot
(GlobDir [Literal "foo"]