14971414dc
Deleting directories is one of the great unsolved problems of CS, thanks to abominations like NFS lock files and Windows and races with other processes cleaning up after themselves in the background. The gpg test harness sometimes failed to delete its temp directory on NFS. Avoid the problem class by not deleting it at all, and putting it inside the tmp repo being tested. The test suite's more robust (and/or nonsensical) workarounds for deleting its test dir will thus be used, hopefully avoiding the problem until an OS finds a new way to violate POSIX and the laws of nature. Note that this means that the .gnupg directory will be on whatever filesystem the test suite is being run on, which may be a lesser quality filesystem than gpg is really expecting. Gpg does not seem to need to write sockets etc to there so this seems ok. The only known problem is that if the filesystem forces a directory mode like 777, gpg will warn about unsafe home directory perms, but it still works.
187 lines
5.1 KiB
Haskell
187 lines
5.1 KiB
Haskell
{- File mode utilities.
|
|
-
|
|
- Copyright 2010-2017 Joey Hess <id@joeyh.name>
|
|
-
|
|
- License: BSD-2-clause
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Utility.FileMode (
|
|
module Utility.FileMode,
|
|
FileMode,
|
|
) where
|
|
|
|
import System.IO
|
|
import Control.Monad
|
|
import System.PosixCompat.Types
|
|
import System.PosixCompat.Files
|
|
#ifndef mingw32_HOST_OS
|
|
import System.Posix.Files (symbolicLinkMode)
|
|
import Control.Monad.IO.Class (liftIO)
|
|
#endif
|
|
import Control.Monad.IO.Class (MonadIO)
|
|
import Foreign (complement)
|
|
import Control.Monad.Catch
|
|
|
|
import Utility.Exception
|
|
|
|
{- Applies a conversion function to a file's mode. -}
|
|
modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO ()
|
|
modifyFileMode f convert = void $ modifyFileMode' f convert
|
|
|
|
modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode
|
|
modifyFileMode' f convert = do
|
|
s <- getFileStatus f
|
|
let old = fileMode s
|
|
let new = convert old
|
|
when (new /= old) $
|
|
setFileMode f new
|
|
return old
|
|
|
|
{- Runs an action after changing a file's mode, then restores the old mode. -}
|
|
withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a
|
|
withModifiedFileMode file convert a = bracket setup cleanup go
|
|
where
|
|
setup = modifyFileMode' file convert
|
|
cleanup oldmode = modifyFileMode file (const oldmode)
|
|
go _ = a
|
|
|
|
{- Adds the specified FileModes to the input mode, leaving the rest
|
|
- unchanged. -}
|
|
addModes :: [FileMode] -> FileMode -> FileMode
|
|
addModes ms m = combineModes (m:ms)
|
|
|
|
{- Removes the specified FileModes from the input mode. -}
|
|
removeModes :: [FileMode] -> FileMode -> FileMode
|
|
removeModes ms m = m `intersectFileModes` complement (combineModes ms)
|
|
|
|
writeModes :: [FileMode]
|
|
writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode]
|
|
|
|
readModes :: [FileMode]
|
|
readModes = [ownerReadMode, groupReadMode, otherReadMode]
|
|
|
|
executeModes :: [FileMode]
|
|
executeModes = [ownerExecuteMode, groupExecuteMode, otherExecuteMode]
|
|
|
|
otherGroupModes :: [FileMode]
|
|
otherGroupModes =
|
|
[ groupReadMode, otherReadMode
|
|
, groupWriteMode, otherWriteMode
|
|
, groupExecuteMode, otherExecuteMode
|
|
]
|
|
|
|
{- Removes the write bits from a file. -}
|
|
preventWrite :: FilePath -> IO ()
|
|
preventWrite f = modifyFileMode f $ removeModes writeModes
|
|
|
|
{- Turns a file's owner write bit back on. -}
|
|
allowWrite :: FilePath -> IO ()
|
|
allowWrite f = modifyFileMode f $ addModes [ownerWriteMode]
|
|
|
|
{- Turns a file's owner read bit back on. -}
|
|
allowRead :: FilePath -> IO ()
|
|
allowRead f = modifyFileMode f $ addModes [ownerReadMode]
|
|
|
|
{- Allows owner and group to read and write to a file. -}
|
|
groupSharedModes :: [FileMode]
|
|
groupSharedModes =
|
|
[ ownerWriteMode, groupWriteMode
|
|
, ownerReadMode, groupReadMode
|
|
]
|
|
|
|
groupWriteRead :: FilePath -> IO ()
|
|
groupWriteRead f = modifyFileMode f $ addModes groupSharedModes
|
|
|
|
checkMode :: FileMode -> FileMode -> Bool
|
|
checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor
|
|
|
|
{- Checks if a file mode indicates it's a symlink. -}
|
|
isSymLink :: FileMode -> Bool
|
|
#ifdef mingw32_HOST_OS
|
|
isSymLink _ = False
|
|
#else
|
|
isSymLink = checkMode symbolicLinkMode
|
|
#endif
|
|
|
|
{- Checks if a file has any executable bits set. -}
|
|
isExecutable :: FileMode -> Bool
|
|
isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0
|
|
|
|
{- Runs an action without that pesky umask influencing it, unless the
|
|
- passed FileMode is the standard one. -}
|
|
noUmask :: (MonadIO m, MonadMask m) => FileMode -> m a -> m a
|
|
#ifndef mingw32_HOST_OS
|
|
noUmask mode a
|
|
| mode == stdFileMode = a
|
|
| otherwise = withUmask nullFileMode a
|
|
#else
|
|
noUmask _ a = a
|
|
#endif
|
|
|
|
withUmask :: (MonadIO m, MonadMask m) => FileMode -> m a -> m a
|
|
#ifndef mingw32_HOST_OS
|
|
withUmask umask a = bracket setup cleanup go
|
|
where
|
|
setup = liftIO $ setFileCreationMask umask
|
|
cleanup = liftIO . setFileCreationMask
|
|
go _ = a
|
|
#else
|
|
withUmask _ a = a
|
|
#endif
|
|
|
|
getUmask :: IO FileMode
|
|
#ifndef mingw32_HOST_OS
|
|
getUmask = bracket setup cleanup return
|
|
where
|
|
setup = setFileCreationMask nullFileMode
|
|
cleanup = setFileCreationMask
|
|
#else
|
|
getUmask = return nullFileMode
|
|
#endif
|
|
|
|
defaultFileMode :: IO FileMode
|
|
defaultFileMode = do
|
|
umask <- getUmask
|
|
return $ intersectFileModes (complement umask) stdFileMode
|
|
|
|
combineModes :: [FileMode] -> FileMode
|
|
combineModes [] = 0
|
|
combineModes [m] = m
|
|
combineModes (m:ms) = foldl unionFileModes m ms
|
|
|
|
isSticky :: FileMode -> Bool
|
|
#ifdef mingw32_HOST_OS
|
|
isSticky _ = False
|
|
#else
|
|
isSticky = checkMode stickyMode
|
|
|
|
stickyMode :: FileMode
|
|
stickyMode = 512
|
|
|
|
setSticky :: FilePath -> IO ()
|
|
setSticky f = modifyFileMode f $ addModes [stickyMode]
|
|
#endif
|
|
|
|
{- Writes a file, ensuring that its modes do not allow it to be read
|
|
- or written by anyone other than the current user,
|
|
- before any content is written.
|
|
-
|
|
- When possible, this is done using the umask.
|
|
-
|
|
- On a filesystem that does not support file permissions, this is the same
|
|
- as writeFile.
|
|
-}
|
|
writeFileProtected :: FilePath -> String -> IO ()
|
|
writeFileProtected file content = writeFileProtected' file
|
|
(\h -> hPutStr h content)
|
|
|
|
writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO ()
|
|
writeFileProtected' file writer = protectedOutput $
|
|
withFile file WriteMode $ \h -> do
|
|
void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes
|
|
writer h
|
|
|
|
protectedOutput :: IO a -> IO a
|
|
protectedOutput = withUmask 0o0077
|