1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
|
{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}
module System.Unix.Directory
( find
, removeRecursiveSafely
, unmountRecursiveSafely
, renameFileWithBackup
, withWorkingDirectory
, withTemporaryDirectory
, mkdtemp
)
where
import Control.Exception
import Data.List (isSuffixOf)
import System.Cmd
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import System.Posix.Files
import System.Posix.Types
import Foreign.C
-- | Traverse a directory and return a list of all the (path,
-- fileStatus) pairs.
find :: FilePath -> IO [(FilePath, FileStatus)]
find path =
do
status <- getSymbolicLinkStatus path
case isDirectory status of
True ->
do
subs <- getDirectoryContents path >>=
return . map (path </>) . filter (not . flip elem [".", ".."]) >>=
mapM find >>=
return . concat
return $ (path, status) : subs
False ->
return [(path, status)]
traverse :: FilePath -> (FilePath -> IO ()) -> (FilePath -> IO ()) -> (FilePath -> IO ()) -> IO ()
-- ^ Traverse a file system directory applying D to every directory, F
-- to every non-directory file, and M to every mount point.
-- NOTE: It is tempting to use the "find" function to returns a list
-- of the elements of the directory and then map that list over an
-- "unmount and remove" function. However, because we are unmounting
-- as we traverse, the contents of the file list may change in ways
-- that could confuse the find function.
traverse path f d m =
do
result <- try $ getSymbolicLinkStatus path
either (\ (_ :: SomeException) -> return ()) (doPath path) result
where
doPath path status =
if isDirectory status then
do
getDirectoryContents path >>= mapM (doDirectoryFile 1 status path)
d path else
f path
doDirectoryFile :: Int -> FileStatus -> FilePath -> String -> IO ()
doDirectoryFile _ _ _ "." = return ()
doDirectoryFile _ _ _ ".." = return ()
doDirectoryFile tries _ _ _ | tries >= 5 =
error ("Couldn't unmount file system on " ++ path)
doDirectoryFile tries status path name =
do
let child = path </> name
childStatus <- getSymbolicLinkStatus child
if deviceID status == deviceID childStatus then
doPath child childStatus else
do
if tries > 1 then hPutStrLn stderr ("try " ++ show tries ++ ":") else return ()
m child
doDirectoryFile (tries + 1) status path name
-- |Recursively remove a directory contents on a single file system.
-- The adjective \"Safely\" refers to these features:
-- 1. It will not follow symlinks
-- 2. If it finds a directory that seems to be a mount point,
-- it will attempt to unmount it up to five times. If it
-- still seems to be a mount point it gives up
-- 3. It doesn't use /proc/mounts, which is ambiguous or wrong
-- when you are inside a chroot.
removeRecursiveSafely :: FilePath -> IO ()
removeRecursiveSafely path =
traverse path removeFile removeDirectory umount
where
umount path =
do
hPutStrLn stderr ("-- removeRecursiveSafely: unmounting " ++ path)
-- This is less likely to hang and more likely to succeed
-- than regular umount.
let cmd = "umount -l " ++ path
result <- system cmd
case result of
ExitSuccess -> return ()
ExitFailure n -> error ("Failure: " ++ cmd ++ " -> " ++ show n)
unmountRecursiveSafely :: FilePath -> IO ()
-- ^ Like removeRecursiveSafely but doesn't remove any files, just
-- unmounts anything it finds mounted. Note that this can be much
-- slower than Mount.umountBelow, use that instead.
unmountRecursiveSafely path =
traverse path noOp noOp umount
where
noOp _ = return ()
umount path =
do
hPutStrLn stderr ("-- unmountRecursiveSafely: unmounting " ++ path)
-- This is less likely to hang and more likely to succeed
-- than regular umount.
let cmd = "umount -l " ++ path
code <- system cmd
case code of
ExitSuccess -> return ()
ExitFailure n -> error ("Failure: " ++ cmd ++ " -> " ++ show n)
-- |Rename src to dst, and if dst already exists move it to dst~.
-- If dst~ exists it is removed.
renameFileWithBackup :: FilePath -> FilePath -> IO ()
renameFileWithBackup src dst =
do
removeIfExists (dst ++ "~")
renameIfExists dst (dst ++ "~")
System.Directory.renameFile src dst
where
removeIfExists path =
do exists <- doesFileExist path
if exists then removeFile path else return ()
renameIfExists src dst =
do exists <- doesFileExist src
if exists then System.Directory.renameFile src dst else return ()
-- |temporarily change the working directory to |dir| while running |action|
withWorkingDirectory :: FilePath -> IO a -> IO a
withWorkingDirectory dir action =
bracket getCurrentDirectory setCurrentDirectory (\ _ -> setCurrentDirectory dir >> action)
-- |create a temporary directory, run the action, remove the temporary directory
-- the first argument is a template for the temporary directory name
-- the directory will be created as a subdirectory of the directory returned by getTemporaryDirectory
-- the temporary directory will be automatically removed afterwards.
-- your working directory is not altered
withTemporaryDirectory :: FilePath -> (FilePath -> IO a) -> IO a
withTemporaryDirectory fp f =
do sysTmpDir <- getTemporaryDirectory
bracket (mkdtemp (sysTmpDir </> fp))
removeRecursiveSafely
f
foreign import ccall unsafe "stdlib.h mkdtemp"
c_mkdtemp :: CString -> IO CString
mkdtemp :: FilePath -> IO FilePath
mkdtemp template =
withCString (if "XXXXXX" `isSuffixOf` template then template else (template ++ "XXXXXX")) $ \ ptr -> do
cname <- throwErrnoIfNull "mkdtemp" (c_mkdtemp ptr)
name <- peekCString cname
return name
|
