summaryrefslogtreecommitdiff
path: root/src/Utility/FileMode.hs
blob: 7d36c554a5d91d770fa60d8d74fed4b81522b226 (plain)
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
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
{- 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