Recursive globs in file monitoring

Author: tdammers

Cabal/src/Distribution/Simple/Glob/Internal.hs

@@ -31,6 +31,9 @@ data Glob
     GlobDir !GlobPieces !Glob
   | -- | @**/<glob>@, where @**@ denotes recursively traversing
     -- all directories and matching filenames on <glob>.
+    --
+    -- Note that the @<glob>@ portion can only match on filenames, not paths,
+    -- so for example @**/foo/*.txt@ is not supported.
     GlobDirRecursive !GlobPieces
   | -- | A file glob.
     GlobFile !GlobPieces
@@ -74,13 +77,6 @@ instance Pretty Glob where
 instance Parsec Glob where
   parsec = parsecPath
     where
-      parsecPath :: CabalParsing m => m Glob
-      parsecPath = do
-        glob <- parsecGlob
-        dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob)
-      -- We could support parsing recursive directory search syntax
-      -- @**@ here too, rather than just in 'parseFileGlob'
-
       dirSep :: CabalParsing m => m ()
       dirSep =
         () <$ P.char '/'
@@ -91,6 +87,17 @@ instance Parsec Glob where
                 P.notFollowedBy (P.satisfy isGlobEscapedChar)
             )
 
+      parsecPath :: CabalParsing m => m Glob
+      parsecPath =
+        P.choice
+          [ do
+              P.try (P.string "**" *> dirSep)
+              GlobDirRecursive <$> parsecGlob
+          , do
+              glob <- parsecGlob
+              dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob)
+          ]
+
       parsecGlob :: CabalParsing m => m GlobPieces
       parsecGlob = some parsecPiece
         where

cabal-install/src/Distribution/Client/FileMonitor.hs

@@ -127,17 +127,47 @@ data MonitorStateGlob
       !MonitorStateGlobRel
   deriving (Show, Generic)
 
+-- | Monitoring state for a 'Glob'. Constructors mirror those of Glob
 data MonitorStateGlobRel
-  = MonitorStateGlobDirs
+  = -- | Monitoring state for 'GlobDir'
+    MonitorStateGlobDirs
       !GlobPieces
+      -- ^ Glob matching on subdirectory in current directory
       !Glob
+      -- ^ Glob tail matching on anything below subdirectory
       !ModTime
-      ![(FilePath, MonitorStateGlobRel)] -- invariant: sorted
-  | MonitorStateGlobFiles
+      -- ^ Cached directory modification time
+      ![(FilePath, MonitorStateGlobRel)]
+      -- ^ Per-file monitoring state.
+      -- Invariant: sorted
+  | -- | Monitoring state for 'GlobFile'
+    MonitorStateGlobFiles
       !GlobPieces
+      -- ^ Glob matching on file in current directory
       !ModTime
+      -- ^ Cached directory modification time
       ![(FilePath, MonitorStateFileStatus)] -- invariant: sorted
-  | MonitorStateGlobDirTrailing
+
+      -- ^ Per-file monitoring state.
+      -- Invariant: sorted
+  | -- | Monitoring state for 'GlobDirRecursive'
+    MonitorStateGlobRecursive
+      !GlobPieces
+      -- ^ Glob matching on file in current directory subtree (current
+      -- directory and all of its descendants).
+      !ModTime
+      -- ^ Cached directory modification time
+      ![(FilePath, MonitorStateFileStatus)]
+      -- ^ Per-file monitoring state for files immediately below the current
+      -- directory.
+      -- Invariant: sorted
+      ![(FilePath, MonitorStateGlobRel)]
+      -- ^ Monitoring state for immediate subdirectories. Transient
+      -- subdirectories are represented recursively within these.
+      -- Invariant: sorted
+  | -- | Monitoring state for 'GlobDirTrailing'
+    -- (Trivial, because there is no data in 'GlobDirTrailing')
+    MonitorStateGlobDirTrailing
   deriving (Show, Generic)
 
 instance Binary MonitorStateGlob
@@ -161,10 +191,18 @@ reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) =
     getGlobPath (MonitorStateGlob kindfile kinddir root gstate) =
       MonitorFileGlob kindfile kinddir $
         RootedGlob root $
-          case gstate of
-            MonitorStateGlobDirs glob globs _ _ -> GlobDir glob globs
-            MonitorStateGlobFiles glob _ _ -> GlobFile glob
-            MonitorStateGlobDirTrailing -> GlobDirTrailing
+          monitorStateGlobRelGlob gstate
+
+-- | Reconstruct a 'Glob' from a 'MonitorStateGlobRel'. This simply erases the
+-- additional information in 'MonitorStateGlobRel' added via
+-- 'buildMonitorStateGlobRel'.
+monitorStateGlobRelGlob :: MonitorStateGlobRel -> Glob
+monitorStateGlobRelGlob gstate =
+  case gstate of
+    MonitorStateGlobDirs glob globs _ _ -> GlobDir glob globs
+    MonitorStateGlobFiles glob _ _ -> GlobFile glob
+    MonitorStateGlobRecursive glob _ _ _ -> GlobDirRecursive glob
+    MonitorStateGlobDirTrailing -> GlobDirTrailing
 
 ------------------------------------------------------------------------------
 -- Checking the status of monitored files
@@ -522,22 +560,84 @@ probeMonitorStateGlob
           MonitorStateGlob kindfile kinddir globroot
             <$> probeMonitorStateGlobRel kindfile kinddir root "" glob
 
-probeMonitorStateGlobRel
+probeMonitorStateFiles
+  :: FilePath
+  -- ^ root path
+  -> FilePath
+  -- ^ path of the directory we are
+  --   looking in relative to @root@
+  -> GlobPieces
+  -- ^ file glob to filter monitored files
+  -> ModTime
+  -- ^ cached directory modification time
+  -> [(FilePath, MonitorStateFileStatus)]
+  -> ChangedM (ModTime, [(FilePath, MonitorStateFileStatus)])
+probeMonitorStateFiles
+  root
+  dirName
+  glob
+  mtime
+  children = do
+    change <- liftIO $ checkDirectoryModificationTime (root </> dirName) mtime
+    mtime' <- case change of
+      Nothing -> return mtime
+      Just mtime' -> do
+        -- directory modification time changed:
+        -- a matching file may have been added or deleted
+        matches <-
+          return . filter (matchGlobPieces glob)
+            =<< liftIO (listDirectory (root </> dirName))
+
+        traverse_ probeMergeResult $
+          mergeBy
+            (\(path1, _) path2 -> compare path1 path2)
+            children
+            (sort matches)
+        return mtime'
+
+    -- Check that none of the children have changed
+    for_ children $ \(file, status) ->
+      probeMonitorStateFileStatus root (dirName </> file) status
+
+    return (mtime', children)
+    where
+      -- Again, we don't force a cache rewrite with 'cacheChanged', but we do use
+      -- the new mtime' if any.
+
+      probeMergeResult
+        :: MergeResult (FilePath, MonitorStateFileStatus) FilePath
+        -> ChangedM ()
+      probeMergeResult mr = case mr of
+        InBoth _ _ -> return ()
+        -- this is just to be able to accurately report which file changed:
+        OnlyInLeft (path, _) -> somethingChanged (dirName </> path)
+        OnlyInRight path -> somethingChanged (dirName </> path)
+
+probeMonitorStateDirs
   :: MonitorKindFile
   -> MonitorKindDir
   -> FilePath
   -- ^ root path
   -> FilePath
   -- ^ path of the directory we are
   --   looking in relative to @root@
-  -> MonitorStateGlobRel
-  -> ChangedM MonitorStateGlobRel
-probeMonitorStateGlobRel
+  -> Maybe GlobPieces
+  -- ^ optional glob to filter filenames by
+  -> Glob
+  -- ^ glob to filter subdirectories by
+  -> ModTime
+  -- ^ cached directory modification time
+  -> [(FilePath, MonitorStateGlobRel)]
+  -> ChangedM (ModTime, [(FilePath, MonitorStateGlobRel)])
+probeMonitorStateDirs
   kindfile
   kinddir
   root
   dirName
-  (MonitorStateGlobDirs glob globPath mtime children) = do
+  globMaybe
+  globPath
+  mtime
+  children = do
     change <- liftIO $ checkDirectoryModificationTime (root </> dirName) mtime
     case change of
       Nothing -> do
@@ -554,7 +654,7 @@ probeMonitorStateGlobRel
               return (fname, fstate')
             | (fname, fstate) <- children
             ]
-        return $! MonitorStateGlobDirs glob globPath mtime children'
+        return $! (mtime, children')
       Just mtime' -> do
         -- directory modification time changed:
         -- a matching subdir may have been added or deleted
@@ -564,7 +664,7 @@ probeMonitorStateGlobRel
                 let subdir = root </> dirName </> entry
                  in liftIO $ doesDirectoryExist subdir
             )
-            . filter (matchGlobPieces glob)
+            . maybe id (filter . matchGlobPieces) globMaybe
             =<< liftIO (listDirectory (root </> dirName))
 
         children' <-
@@ -573,7 +673,7 @@ probeMonitorStateGlobRel
               (\(path1, _) path2 -> compare path1 path2)
               children
               (sort matches)
-        return $! MonitorStateGlobDirs glob globPath mtime' children'
+        return $! (mtime', children')
     where
       -- Note that just because the directory has changed, we don't force
       -- a cache rewrite with 'cacheChanged' since that has some cost, and
@@ -626,17 +726,56 @@ probeMonitorStateGlobRel
             fstate
         return (path, fstate')
 
-      -- \| Does a 'MonitorStateGlob' have any relevant files within it?
-      allMatchingFiles :: FilePath -> MonitorStateGlobRel -> [FilePath]
-      allMatchingFiles dir (MonitorStateGlobFiles _ _ entries) =
+      allMatchingFilesFromGlobFiles :: FilePath -> [(FilePath, a)] -> [FilePath]
+      allMatchingFilesFromGlobFiles dir entries =
         [dir </> fname | (fname, _) <- entries]
-      allMatchingFiles dir (MonitorStateGlobDirs _ _ _ entries) =
+
+      allMatchingFilesFromGlobDirs :: FilePath -> [(FilePath, MonitorStateGlobRel)] -> [FilePath]
+      allMatchingFilesFromGlobDirs dir entries =
         [ res
         | (subdir, fstate) <- entries
         , res <- allMatchingFiles (dir </> subdir) fstate
         ]
+
+      -- \| Does a 'MonitorStateGlob' have any relevant files within it?
+      allMatchingFiles :: FilePath -> MonitorStateGlobRel -> [FilePath]
+      allMatchingFiles dir (MonitorStateGlobFiles _ _ entries) =
+        allMatchingFilesFromGlobFiles dir entries
+      allMatchingFiles dir (MonitorStateGlobDirs _ _ _ entries) =
+        allMatchingFilesFromGlobDirs dir entries
+      allMatchingFiles dir (MonitorStateGlobRecursive _ _ fileEntries dirEntries) =
+        allMatchingFilesFromGlobFiles dir fileEntries
+          ++ allMatchingFilesFromGlobDirs dir dirEntries
       allMatchingFiles dir MonitorStateGlobDirTrailing =
         [dir]
+
+probeMonitorStateGlobRel
+  :: MonitorKindFile
+  -> MonitorKindDir
+  -> FilePath
+  -- ^ root path
+  -> FilePath
+  -- ^ path of the directory we are
+  --   looking in relative to @root@
+  -> MonitorStateGlobRel
+  -> ChangedM MonitorStateGlobRel
+probeMonitorStateGlobRel
+  kindfile
+  kinddir
+  root
+  dirName
+  (MonitorStateGlobDirs glob globPath mtime children) = do
+    (mtime', children') <-
+      probeMonitorStateDirs
+        kindfile
+        kinddir
+        root
+        dirName
+        (Just glob)
+        globPath
+        mtime
+        children
+    return $! MonitorStateGlobDirs glob globPath mtime' children'
 probeMonitorStateGlobRel
   _
   _
@@ -677,6 +816,33 @@ probeMonitorStateGlobRel
         -- this is just to be able to accurately report which file changed:
         OnlyInLeft (path, _) -> somethingChanged (dirName </> path)
         OnlyInRight path -> somethingChanged (dirName </> path)
+probeMonitorStateGlobRel
+  kindfile
+  kinddir
+  root
+  dirName
+  (MonitorStateGlobRecursive glob mtime fileChildren dirChildren) = do
+    -- For recursive globs, we check the file children first, then recurse
+    -- into subdirectories, applying the same logic as 'MonitorStateGlobFiles'
+    -- and 'MonitorStateGlobDirs', respectively.
+    (_, fileChildren') <-
+      probeMonitorStateFiles
+        root
+        dirName
+        glob
+        mtime
+        fileChildren
+    (mtime', dirChildren') <-
+      probeMonitorStateDirs
+        kindfile
+        kinddir
+        root
+        dirName
+        Nothing
+        (GlobDirRecursive glob)
+        mtime
+        dirChildren
+    return $! MonitorStateGlobRecursive glob mtime' fileChildren' dirChildren'
 probeMonitorStateGlobRel _ _ _ _ MonitorStateGlobDirTrailing =
   return MonitorStateGlobDirTrailing
 
@@ -916,7 +1082,37 @@ buildMonitorStateGlobRel
     dirEntries <- listDirectory absdir
     dirMTime <- getModTime absdir
     case globPath of
-      GlobDirRecursive{} -> error "Monitoring directory-recursive globs (i.e. ../**/...) is currently unsupported"
+      GlobDirRecursive glob -> do
+        -- evaluate globPath' over the current directory
+        let files = filter (matchGlobPieces glob) dirEntries
+        filesStates <-
+          for (sort files) $ \file -> do
+            fstate <-
+              buildMonitorStateFile
+                mstartTime
+                hashcache
+                kindfile
+                kinddir
+                root
+                (dir </> file)
+            return (file, fstate)
+        -- evaluate globPath' over every subdirectory
+        subdirs <-
+          filterM (\subdir -> doesDirectoryExist (absdir </> subdir)) dirEntries
+        subdirStates <-
+          for (sort subdirs) $ \subdir -> do
+            fstate <-
+              buildMonitorStateGlobRel
+                mstartTime
+                hashcache
+                kindfile
+                kinddir
+                root
+                (dir </> subdir)
+                globPath
+            return (subdir, fstate)
+
+        return $! MonitorStateGlobRecursive glob dirMTime filesStates subdirStates
       GlobDir glob globPath' -> do
         subdirs <-
           filterM (\subdir -> doesDirectoryExist (absdir </> subdir)) $
@@ -1015,16 +1211,27 @@ readCacheFileHashes monitor =
         , (fpath, (mtime, hash)) <- collectGlobHashes "" gstate
         ]
 
-    collectGlobHashes :: FilePath -> MonitorStateGlobRel -> [(FilePath, (ModTime, HashValue))]
-    collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) =
+    collectDirHashes :: FilePath -> [(FilePath, MonitorStateGlobRel)] -> [(FilePath, (ModTime, HashValue))]
+    collectDirHashes dir entries =
       [ res
       | (subdir, fstate) <- entries
       , res <- collectGlobHashes (dir </> subdir) fstate
       ]
-    collectGlobHashes dir (MonitorStateGlobFiles _ _ entries) =
+
+    collectFileHashes :: FilePath -> [(FilePath, MonitorStateFileStatus)] -> [(FilePath, (ModTime, HashValue))]
+    collectFileHashes dir entries =
       [ (dir </> fname, (mtime, hash))
       | (fname, MonitorStateFileHashed mtime hash) <- entries
       ]
+
+    collectGlobHashes :: FilePath -> MonitorStateGlobRel -> [(FilePath, (ModTime, HashValue))]
+    collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) =
+      collectDirHashes dir entries
+    collectGlobHashes dir (MonitorStateGlobFiles _ _ entries) =
+      collectFileHashes dir entries
+    collectGlobHashes dir (MonitorStateGlobRecursive _ _ fileEntries dirEntries) =
+      collectFileHashes dir fileEntries
+        ++ collectDirHashes dir dirEntries
     collectGlobHashes _dir MonitorStateGlobDirTrailing =
       []