{- 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 :: FilePath -> (FileMode -> FileMode) -> IO ()
modifyFileMode FilePath
f FileMode -> FileMode
convert = IO FileMode -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO FileMode -> IO ()) -> IO FileMode -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> (FileMode -> FileMode) -> IO FileMode
modifyFileMode' FilePath
f FileMode -> FileMode
convert

modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode
modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode
modifyFileMode' FilePath
f FileMode -> FileMode
convert = do
	FileStatus
s <- FilePath -> IO FileStatus
getFileStatus FilePath
f
	let old :: FileMode
old = FileStatus -> FileMode
fileMode FileStatus
s
	let new :: FileMode
new = FileMode -> FileMode
convert FileMode
old
	Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FileMode
new FileMode -> FileMode -> Bool
forall a. Eq a => a -> a -> Bool
/= FileMode
old) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
		FilePath -> FileMode -> IO ()
setFileMode FilePath
f FileMode
new
	FileMode -> IO FileMode
forall (m :: * -> *) a. Monad m => a -> m a
return FileMode
old

{- Runs an action after changing a file's mode, then restores the old mode. -}
withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a
withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a
withModifiedFileMode FilePath
file FileMode -> FileMode
convert IO a
a = IO FileMode -> (FileMode -> IO ()) -> (FileMode -> IO a) -> IO a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket IO FileMode
setup FileMode -> IO ()
cleanup FileMode -> IO a
forall p. p -> IO a
go
  where
	setup :: IO FileMode
setup = FilePath -> (FileMode -> FileMode) -> IO FileMode
modifyFileMode' FilePath
file FileMode -> FileMode
convert
	cleanup :: FileMode -> IO ()
cleanup FileMode
oldmode = FilePath -> (FileMode -> FileMode) -> IO ()
modifyFileMode FilePath
file (FileMode -> FileMode -> FileMode
forall a b. a -> b -> a
const FileMode
oldmode)
	go :: p -> IO a
go p
_ = IO a
a

{- Adds the specified FileModes to the input mode, leaving the rest
 - unchanged. -}
addModes :: [FileMode] -> FileMode -> FileMode
addModes :: [FileMode] -> FileMode -> FileMode
addModes [FileMode]
ms FileMode
m = [FileMode] -> FileMode
combineModes (FileMode
mFileMode -> [FileMode] -> [FileMode]
forall a. a -> [a] -> [a]
:[FileMode]
ms)

{- Removes the specified FileModes from the input mode. -}
removeModes :: [FileMode] -> FileMode -> FileMode
removeModes :: [FileMode] -> FileMode -> FileMode
removeModes [FileMode]
ms FileMode
m = FileMode
m FileMode -> FileMode -> FileMode
`intersectFileModes` FileMode -> FileMode
forall a. Bits a => a -> a
complement ([FileMode] -> FileMode
combineModes [FileMode]
ms)

writeModes :: [FileMode]
writeModes :: [FileMode]
writeModes = [FileMode
ownerWriteMode, FileMode
groupWriteMode, FileMode
otherWriteMode]

readModes :: [FileMode]
readModes :: [FileMode]
readModes = [FileMode
ownerReadMode, FileMode
groupReadMode, FileMode
otherReadMode]

executeModes :: [FileMode]
executeModes :: [FileMode]
executeModes = [FileMode
ownerExecuteMode, FileMode
groupExecuteMode, FileMode
otherExecuteMode]

otherGroupModes :: [FileMode]
otherGroupModes :: [FileMode]
otherGroupModes = 
	[ FileMode
groupReadMode, FileMode
otherReadMode
	, FileMode
groupWriteMode, FileMode
otherWriteMode
	, FileMode
groupExecuteMode, FileMode
otherExecuteMode
	]

{- Removes the write bits from a file. -}
preventWrite :: FilePath -> IO ()
preventWrite :: FilePath -> IO ()
preventWrite FilePath
f = FilePath -> (FileMode -> FileMode) -> IO ()
modifyFileMode FilePath
f ((FileMode -> FileMode) -> IO ())
-> (FileMode -> FileMode) -> IO ()
forall a b. (a -> b) -> a -> b
$ [FileMode] -> FileMode -> FileMode
removeModes [FileMode]
writeModes

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

{- Turns a file's owner read bit back on. -}
allowRead :: FilePath -> IO ()
allowRead :: FilePath -> IO ()
allowRead FilePath
f = FilePath -> (FileMode -> FileMode) -> IO ()
modifyFileMode FilePath
f ((FileMode -> FileMode) -> IO ())
-> (FileMode -> FileMode) -> IO ()
forall a b. (a -> b) -> a -> b
$ [FileMode] -> FileMode -> FileMode
addModes [FileMode
ownerReadMode]

{- Allows owner and group to read and write to a file. -}
groupSharedModes :: [FileMode]
groupSharedModes :: [FileMode]
groupSharedModes =
	[ FileMode
ownerWriteMode, FileMode
groupWriteMode
	, FileMode
ownerReadMode, FileMode
groupReadMode
	]

groupWriteRead :: FilePath -> IO ()
groupWriteRead :: FilePath -> IO ()
groupWriteRead FilePath
f = FilePath -> (FileMode -> FileMode) -> IO ()
modifyFileMode FilePath
f ((FileMode -> FileMode) -> IO ())
-> (FileMode -> FileMode) -> IO ()
forall a b. (a -> b) -> a -> b
$ [FileMode] -> FileMode -> FileMode
addModes [FileMode]
groupSharedModes

checkMode :: FileMode -> FileMode -> Bool
checkMode :: FileMode -> FileMode -> Bool
checkMode FileMode
checkfor FileMode
mode = FileMode
checkfor FileMode -> FileMode -> FileMode
`intersectFileModes` FileMode
mode FileMode -> FileMode -> Bool
forall a. Eq a => a -> a -> Bool
== FileMode
checkfor

{- Checks if a file mode indicates it's a symlink. -}
isSymLink :: FileMode -> Bool
#ifdef mingw32_HOST_OS
isSymLink _ = False
#else
isSymLink :: FileMode -> Bool
isSymLink = FileMode -> FileMode -> Bool
checkMode FileMode
symbolicLinkMode
#endif

{- Checks if a file has any executable bits set. -}
isExecutable :: FileMode -> Bool
isExecutable :: FileMode -> Bool
isExecutable FileMode
mode = [FileMode] -> FileMode
combineModes [FileMode]
executeModes FileMode -> FileMode -> FileMode
`intersectFileModes` FileMode
mode FileMode -> FileMode -> Bool
forall a. Eq a => a -> a -> Bool
/= FileMode
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 :: FileMode -> m a -> m a
noUmask FileMode
mode m a
a
	| FileMode
mode FileMode -> FileMode -> Bool
forall a. Eq a => a -> a -> Bool
== FileMode
stdFileMode = m a
a
	| Bool
otherwise = FileMode -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FileMode -> m a -> m a
withUmask FileMode
nullFileMode m a
a
#else
noUmask _ a = a
#endif

withUmask :: (MonadIO m, MonadMask m) => FileMode -> m a -> m a
#ifndef mingw32_HOST_OS
withUmask :: FileMode -> m a -> m a
withUmask FileMode
umask m a
a = m FileMode -> (FileMode -> m FileMode) -> (FileMode -> m a) -> m a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket m FileMode
setup FileMode -> m FileMode
cleanup FileMode -> m a
forall p. p -> m a
go
  where
	setup :: m FileMode
setup = IO FileMode -> m FileMode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileMode -> m FileMode) -> IO FileMode -> m FileMode
forall a b. (a -> b) -> a -> b
$ FileMode -> IO FileMode
setFileCreationMask FileMode
umask
	cleanup :: FileMode -> m FileMode
cleanup = IO FileMode -> m FileMode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileMode -> m FileMode)
-> (FileMode -> IO FileMode) -> FileMode -> m FileMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileMode -> IO FileMode
setFileCreationMask
	go :: p -> m a
go p
_ = m a
a
#else
withUmask _ a = a
#endif

getUmask :: IO FileMode
#ifndef mingw32_HOST_OS
getUmask :: IO FileMode
getUmask = IO FileMode
-> (FileMode -> IO FileMode)
-> (FileMode -> IO FileMode)
-> IO FileMode
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket IO FileMode
setup FileMode -> IO FileMode
cleanup FileMode -> IO FileMode
forall (m :: * -> *) a. Monad m => a -> m a
return
  where
	setup :: IO FileMode
setup = FileMode -> IO FileMode
setFileCreationMask FileMode
nullFileMode
	cleanup :: FileMode -> IO FileMode
cleanup = FileMode -> IO FileMode
setFileCreationMask
#else
getUmask = return nullFileMode
#endif

defaultFileMode :: IO FileMode
defaultFileMode :: IO FileMode
defaultFileMode = do
	FileMode
umask <- IO FileMode
getUmask
	FileMode -> IO FileMode
forall (m :: * -> *) a. Monad m => a -> m a
return (FileMode -> IO FileMode) -> FileMode -> IO FileMode
forall a b. (a -> b) -> a -> b
$ FileMode -> FileMode -> FileMode
intersectFileModes (FileMode -> FileMode
forall a. Bits a => a -> a
complement FileMode
umask) FileMode
stdFileMode

combineModes :: [FileMode] -> FileMode
combineModes :: [FileMode] -> FileMode
combineModes [] = FileMode
0
combineModes [FileMode
m] = FileMode
m
combineModes (FileMode
m:[FileMode]
ms) = (FileMode -> FileMode -> FileMode)
-> FileMode -> [FileMode] -> FileMode
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl FileMode -> FileMode -> FileMode
unionFileModes FileMode
m [FileMode]
ms

isSticky :: FileMode -> Bool
#ifdef mingw32_HOST_OS
isSticky _ = False
#else
isSticky :: FileMode -> Bool
isSticky = FileMode -> FileMode -> Bool
checkMode FileMode
stickyMode

stickyMode :: FileMode
stickyMode :: FileMode
stickyMode = FileMode
512

setSticky :: FilePath -> IO ()
setSticky :: FilePath -> IO ()
setSticky FilePath
f = FilePath -> (FileMode -> FileMode) -> IO ()
modifyFileMode FilePath
f ((FileMode -> FileMode) -> IO ())
-> (FileMode -> FileMode) -> IO ()
forall a b. (a -> b) -> a -> b
$ [FileMode] -> FileMode -> FileMode
addModes [FileMode
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 :: FilePath -> FilePath -> IO ()
writeFileProtected FilePath
file FilePath
content = FilePath -> (Handle -> IO ()) -> IO ()
writeFileProtected' FilePath
file 
	(\Handle
h -> Handle -> FilePath -> IO ()
hPutStr Handle
h FilePath
content)

writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO ()
writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO ()
writeFileProtected' FilePath
file Handle -> IO ()
writer = IO () -> IO ()
forall a. IO a -> IO a
protectedOutput (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
	FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
file IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
		IO (Either IOException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException ()) -> IO ())
-> IO (Either IOException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either IOException ())
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ FilePath -> (FileMode -> FileMode) -> IO ()
modifyFileMode FilePath
file ((FileMode -> FileMode) -> IO ())
-> (FileMode -> FileMode) -> IO ()
forall a b. (a -> b) -> a -> b
$ [FileMode] -> FileMode -> FileMode
removeModes [FileMode]
otherGroupModes
		Handle -> IO ()
writer Handle
h

protectedOutput :: IO a -> IO a
protectedOutput :: IO a -> IO a
protectedOutput = FileMode -> IO a -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FileMode -> m a -> m a
withUmask FileMode
0o0077