git-annex/Utility/FileMode.hs

{- File mode utilities.
 -
 - Copyright 2010-2020 Joey Hess <id@joeyh.name>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}

module Utility.FileMode (
	module Utility.FileMode,
	FileMode,
) where

import System.IO
import Control.Monad
import System.PosixCompat.Types
import System.PosixCompat.Files (unionFileModes, intersectFileModes, stdFileMode, nullFileMode, setFileCreationMask, groupReadMode, ownerReadMode, ownerWriteMode, ownerExecuteMode, groupWriteMode, groupExecuteMode, otherReadMode, otherWriteMode, otherExecuteMode, fileMode)
import Control.Monad.IO.Class
import Foreign (complement)
import Control.Monad.Catch

import Utility.Exception
import Utility.FileSystemEncoding
import qualified Utility.RawFilePath as R

{- Applies a conversion function to a file's mode. -}
modifyFileMode :: RawFilePath -> (FileMode -> FileMode) -> IO ()
modifyFileMode f convert = void $ modifyFileMode' f convert

modifyFileMode' :: RawFilePath -> (FileMode -> FileMode) -> IO FileMode
modifyFileMode' f convert = do
	s <- R.getFileStatus f
	let old = fileMode s
	let new = convert old
	when (new /= old) $
		R.setFileMode f new
	return old

{- Runs an action after changing a file's mode, then restores the old mode. -}
withModifiedFileMode :: RawFilePath -> (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 :: RawFilePath -> IO ()
preventWrite f = modifyFileMode f $ removeModes writeModes

{- Turns a file's owner write bit back on. -}
allowWrite :: RawFilePath -> IO ()
allowWrite f = modifyFileMode f $ addModes [ownerWriteMode]

{- Turns a file's owner read bit back on. -}
allowRead :: RawFilePath -> 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 :: RawFilePath -> IO ()
groupWriteRead f = modifyFileMode f $ addModes groupSharedModes

checkMode :: FileMode -> FileMode -> Bool
checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor

{- 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 :: RawFilePath -> 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 :: RawFilePath -> String -> IO ()
writeFileProtected file content = writeFileProtected' file 
	(\h -> hPutStr h content)

writeFileProtected' :: RawFilePath -> (Handle -> IO ()) -> IO ()
writeFileProtected' file writer = protectedOutput $
	withFile (fromRawFilePath file) WriteMode $ \h -> do
		void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes
		writer h

protectedOutput :: IO a -> IO a
protectedOutput = withUmask 0o0077