2bfcc0b09c
This *may* now return Add or Delete Changes as appropriate. All I know for sure is that it compiles. I had hoped to avoid maintaining my own state about the content of the directory tree, and rely on git to check what was changed. But I can't; I need to know about new and deleted subdirectories to add them to the watch list, and git doesn't deal with (empty) directories. So, wrote all the code to scan directories, remember their past contents, compare with current contents, generate appropriate Change events, and update bookkeeping info appropriately.
106 lines
3.2 KiB
Haskell
106 lines
3.2 KiB
Haskell
{- directory manipulation
|
|
-
|
|
- Copyright 2011 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Utility.Directory where
|
|
|
|
import System.IO.Error
|
|
import System.Posix.Files
|
|
import System.Directory
|
|
import Control.Exception (throw, bracket_)
|
|
import Control.Monad
|
|
import Control.Monad.IfElse
|
|
import System.FilePath
|
|
import Control.Applicative
|
|
import System.Posix.Directory
|
|
import System.IO.Unsafe (unsafeInterleaveIO)
|
|
|
|
import Utility.SafeCommand
|
|
import Utility.TempFile
|
|
import Utility.Exception
|
|
import Utility.Monad
|
|
import Utility.Path
|
|
|
|
dirCruft :: FilePath -> Bool
|
|
dirCruft "." = True
|
|
dirCruft ".." = True
|
|
dirCruft _ = False
|
|
|
|
{- Lists the contents of a directory.
|
|
- Unlike getDirectoryContents, paths are not relative to the directory. -}
|
|
dirContents :: FilePath -> IO [FilePath]
|
|
dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d
|
|
|
|
{- Gets files in a directory, and then its subdirectories, recursively,
|
|
- and lazily. -}
|
|
dirContentsRecursive :: FilePath -> IO [FilePath]
|
|
dirContentsRecursive topdir = dirContentsRecursive' topdir [""]
|
|
|
|
dirContentsRecursive' :: FilePath -> [FilePath] -> IO [FilePath]
|
|
dirContentsRecursive' _ [] = return []
|
|
dirContentsRecursive' topdir (dir:dirs) = unsafeInterleaveIO $ do
|
|
(files, dirs') <- collect [] [] =<< dirContents (topdir </> dir)
|
|
files' <- dirContentsRecursive' topdir (dirs' ++ dirs)
|
|
return (files ++ files')
|
|
where
|
|
collect files dirs' [] = return (reverse files, reverse dirs')
|
|
collect files dirs' (entry:entries)
|
|
| dirCruft entry = collect files dirs' entries
|
|
| otherwise = do
|
|
let dirEntry = dir </> entry
|
|
ifM (doesDirectoryExist $ topdir </> dirEntry)
|
|
( collect files (dirEntry:dirs') entries
|
|
, collect (dirEntry:files) dirs' entries
|
|
)
|
|
|
|
{- Moves one filename to another.
|
|
- First tries a rename, but falls back to moving across devices if needed. -}
|
|
moveFile :: FilePath -> FilePath -> IO ()
|
|
moveFile src dest = tryIO (rename src dest) >>= onrename
|
|
where
|
|
onrename (Right _) = noop
|
|
onrename (Left e)
|
|
| isPermissionError e = rethrow
|
|
| isDoesNotExistError e = rethrow
|
|
| otherwise = do
|
|
-- copyFile is likely not as optimised as
|
|
-- the mv command, so we'll use the latter.
|
|
-- But, mv will move into a directory if
|
|
-- dest is one, which is not desired.
|
|
whenM (isdir dest) rethrow
|
|
viaTmp mv dest undefined
|
|
where
|
|
rethrow = throw e
|
|
mv tmp _ = do
|
|
ok <- boolSystem "mv" [Param "-f",
|
|
Param src, Param tmp]
|
|
unless ok $ do
|
|
-- delete any partial
|
|
_ <- tryIO $ removeFile tmp
|
|
rethrow
|
|
isdir f = do
|
|
r <- tryIO $ getFileStatus f
|
|
case r of
|
|
(Left _) -> return False
|
|
(Right s) -> return $ isDirectory s
|
|
|
|
{- Removes a file, which may or may not exist.
|
|
-
|
|
- Note that an exception is thrown if the file exists but
|
|
- cannot be removed. -}
|
|
nukeFile :: FilePath -> IO ()
|
|
nukeFile file = whenM (doesFileExist file) $ removeFile file
|
|
|
|
{- Runs an action in another directory. -}
|
|
bracketCd :: FilePath -> IO a -> IO a
|
|
bracketCd dir a = go =<< getCurrentDirectory
|
|
where
|
|
go cwd
|
|
| dirContains dir cwd = a
|
|
| otherwise = bracket_
|
|
(changeWorkingDirectory dir)
|
|
(changeWorkingDirectory cwd)
|
|
a
|