1{- git-annex file permissions
2 -
3 - Copyright 2012-2021 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8module Annex.Perms (
9	FileMode,
10	setAnnexFilePerm,
11	setAnnexDirPerm,
12	resetAnnexFilePerm,
13	annexFileMode,
14	createAnnexDirectory,
15	createWorkTreeDirectory,
16	noUmask,
17	freezeContent,
18	freezeContent',
19	checkContentWritePerm,
20	checkContentWritePerm',
21	thawContent,
22	thawContent',
23	createContentDir,
24	freezeContentDir,
25	thawContentDir,
26	modifyContent,
27	withShared,
28) where
29
30import Annex.Common
31import Utility.FileMode
32import Git
33import Git.ConfigTypes
34import qualified Annex
35import Config
36import Utility.Directory.Create
37import qualified Utility.RawFilePath as R
38
39withShared :: (SharedRepository -> Annex a) -> Annex a
40withShared a = a =<< coreSharedRepository <$> Annex.getGitConfig
41
42setAnnexFilePerm :: RawFilePath -> Annex ()
43setAnnexFilePerm = setAnnexPerm False
44
45setAnnexDirPerm :: RawFilePath -> Annex ()
46setAnnexDirPerm = setAnnexPerm True
47
48{- Sets appropriate file mode for a file or directory in the annex,
49 - other than the content files and content directory. Normally,
50 - don't change the mode, but with core.sharedRepository set,
51 - allow the group to write, etc. -}
52setAnnexPerm :: Bool -> RawFilePath -> Annex ()
53setAnnexPerm = setAnnexPerm' Nothing
54
55setAnnexPerm' :: Maybe ([FileMode] -> FileMode -> FileMode) -> Bool -> RawFilePath -> Annex ()
56setAnnexPerm' modef isdir file = unlessM crippledFileSystem $
57	withShared $ liftIO . go
58  where
59	go GroupShared = void $ tryIO $ modifyFileMode file $ modef' $
60		groupSharedModes ++
61		if isdir then [ ownerExecuteMode, groupExecuteMode ] else []
62	go AllShared = void $ tryIO $ modifyFileMode file $ modef' $
63		readModes ++
64		[ ownerWriteMode, groupWriteMode ] ++
65		if isdir then executeModes else []
66	go _ = case modef of
67		Nothing -> noop
68		Just f -> void $ tryIO $
69			modifyFileMode file $ f []
70	modef' = fromMaybe addModes modef
71
72resetAnnexFilePerm :: RawFilePath -> Annex ()
73resetAnnexFilePerm = resetAnnexPerm False
74
75{- Like setAnnexPerm, but ignores the current mode of the file entirely,
76 - and sets the same mode that the umask would result in when creating a
77 - new file.
78 -
79 - Useful eg, after creating a temporary file with locked down modes,
80 - which is going to be moved to a non-temporary location and needs
81 - usual modes.
82 -}
83resetAnnexPerm :: Bool -> RawFilePath -> Annex ()
84resetAnnexPerm isdir file = unlessM crippledFileSystem $ do
85	defmode <- liftIO defaultFileMode
86	let modef moremodes _oldmode = addModes moremodes defmode
87	setAnnexPerm' (Just modef) isdir file
88
89{- Gets the appropriate mode to use for creating a file in the annex
90 - (other than content files, which are locked down more). The umask is not
91 - taken into account; this is for use with actions that create the file
92 - and apply the umask automatically. -}
93annexFileMode :: Annex FileMode
94annexFileMode = withShared $ return . go
95  where
96	go GroupShared = sharedmode
97	go AllShared = combineModes (sharedmode:readModes)
98	go _ = stdFileMode
99	sharedmode = combineModes groupSharedModes
100
101{- Creates a directory inside the gitAnnexDir, creating any parent
102 - directories up to and including the gitAnnexDir.
103 - Makes directories with appropriate permissions. -}
104createAnnexDirectory :: RawFilePath -> Annex ()
105createAnnexDirectory dir = do
106	top <- parentDir <$> fromRepo gitAnnexDir
107	createDirectoryUnder' top dir createdir
108  where
109	createdir p = do
110		liftIO $ R.createDirectory p
111		setAnnexDirPerm p
112
113{- Create a directory in the git work tree, creating any parent
114 - directories up to the top of the work tree.
115 -
116 - Uses default permissions.
117 -}
118createWorkTreeDirectory :: RawFilePath -> Annex ()
119createWorkTreeDirectory dir = do
120	fromRepo repoWorkTree >>= liftIO . \case
121		Just wt -> createDirectoryUnder wt dir
122		-- Should never happen, but let whatever tries to write
123		-- to the directory be what throws an exception, as that
124		-- will be clearer than an exception from here.
125		Nothing -> noop
126
127{- Normally, blocks writing to an annexed file, and modifies file
128 - permissions to allow reading it.
129 -
130 - When core.sharedRepository is set, the write bits are not removed from
131 - the file, but instead the appropriate group write bits are set. This is
132 - necessary to let other users in the group lock the file. But, in a
133 - shared repository, the current user may not be able to change a file
134 - owned by another user, so failure to set this mode is ignored.
135 -
136 - Note that, on Linux, xattrs can sometimes prevent removing
137 - certain permissions from a file with chmod. (Maybe some ACLs too?)
138 - In such a case, this will return with the file still having some mode
139 - it should not normally have. checkContentWritePerm can detect when
140 - that happens with write permissions.
141 -}
142freezeContent :: RawFilePath -> Annex ()
143freezeContent file = unlessM crippledFileSystem $
144	withShared $ \sr -> freezeContent' sr file
145
146freezeContent' :: SharedRepository -> RawFilePath -> Annex ()
147freezeContent' sr file = do
148	go sr
149	freezeHook file
150  where
151	go GroupShared = liftIO $ void $ tryIO $ modifyFileMode file $
152		addModes [ownerReadMode, groupReadMode, ownerWriteMode, groupWriteMode]
153	go AllShared = liftIO $ void $ tryIO $ modifyFileMode file $
154		addModes (readModes ++ writeModes)
155	go _ = liftIO $ modifyFileMode file $
156		removeModes writeModes .
157		addModes [ownerReadMode]
158
159{- Checks if the write permissions are as freezeContent should set them.
160 -
161 - When the repository is shared, the user may not be able to change
162 - permissions of a file owned by another user. So if the permissions seem
163 - wrong, but the repository is shared, returns Nothing. If the permissions
164 - are wrong otherwise, returns Just False.
165 -}
166checkContentWritePerm :: RawFilePath -> Annex (Maybe Bool)
167checkContentWritePerm file = ifM crippledFileSystem
168	( return (Just True)
169	, withShared (\sr -> liftIO (checkContentWritePerm' sr file))
170	)
171
172checkContentWritePerm' :: SharedRepository -> RawFilePath -> IO (Maybe Bool)
173checkContentWritePerm' sr file = case sr of
174	GroupShared -> want sharedret
175		(includemodes [ownerWriteMode, groupWriteMode])
176	AllShared -> want sharedret (includemodes writeModes)
177	_ -> want Just (excludemodes writeModes)
178  where
179	want mk f = catchMaybeIO (fileMode <$> R.getFileStatus file)
180		>>= return . \case
181			Just havemode -> mk (f havemode)
182			Nothing -> mk True
183
184	includemodes l havemode = havemode == combineModes (havemode:l)
185	excludemodes l havemode = all (\m -> intersectFileModes m havemode == nullFileMode) l
186
187	sharedret True = Just True
188	sharedret False = Nothing
189
190{- Allows writing to an annexed file that freezeContent was called on
191 - before. -}
192thawContent :: RawFilePath -> Annex ()
193thawContent file = withShared $ \sr -> thawContent' sr file
194
195thawContent' :: SharedRepository -> RawFilePath -> Annex ()
196thawContent' sr file = thawPerms (go sr) (thawHook file)
197  where
198	go GroupShared = liftIO $ void $ tryIO $ groupWriteRead file
199	go AllShared = liftIO $ void $ tryIO $ groupWriteRead file
200	go _ = liftIO $ allowWrite file
201
202{- Runs an action that thaws a file's permissions. This will probably
203 - fail on a crippled filesystem. But, if file modes are supported on a
204 - crippled filesystem, the file may be frozen, so try to thaw its
205 - permissions. -}
206thawPerms :: Annex () -> Annex () -> Annex ()
207thawPerms a hook = ifM crippledFileSystem
208	( void (tryNonAsync a)
209	, hook >> a
210	)
211
212{- Blocks writing to the directory an annexed file is in, to prevent the
213 - file accidentally being deleted. However, if core.sharedRepository
214 - is set, this is not done, since the group must be allowed to delete the
215 - file.
216 -}
217freezeContentDir :: RawFilePath -> Annex ()
218freezeContentDir file = unlessM crippledFileSystem $ do
219	withShared go
220	freezeHook dir
221  where
222	dir = parentDir file
223	go GroupShared = liftIO $ void $ tryIO $ groupWriteRead dir
224	go AllShared = liftIO $ void $ tryIO $ groupWriteRead dir
225	go _ = liftIO $ preventWrite dir
226
227thawContentDir :: RawFilePath -> Annex ()
228thawContentDir file = thawPerms (liftIO $ allowWrite dir) (thawHook dir)
229  where
230	dir = parentDir file
231
232{- Makes the directory tree to store an annexed file's content,
233 - with appropriate permissions on each level. -}
234createContentDir :: RawFilePath -> Annex ()
235createContentDir dest = do
236	unlessM (liftIO $ R.doesPathExist dir) $
237		createAnnexDirectory dir
238	-- might have already existed with restricted perms
239	unlessM crippledFileSystem $ do
240		thawHook dir
241		liftIO $ allowWrite dir
242  where
243	dir = parentDir dest
244
245{- Creates the content directory for a file if it doesn't already exist,
246 - or thaws it if it does, then runs an action to modify the file, and
247 - finally, freezes the content directory. -}
248modifyContent :: RawFilePath -> Annex a -> Annex a
249modifyContent f a = do
250	createContentDir f -- also thaws it
251	v <- tryNonAsync a
252	freezeContentDir f
253	either throwM return v
254
255freezeHook :: RawFilePath -> Annex ()
256freezeHook p = maybe noop go =<< annexFreezeContentCommand <$> Annex.getGitConfig
257  where
258	go basecmd = void $ liftIO $
259		boolSystem "sh" [Param "-c", Param $ gencmd basecmd]
260	gencmd = massReplace [ ("%path", shellEscape (fromRawFilePath p)) ]
261
262thawHook :: RawFilePath -> Annex ()
263thawHook p = maybe noop go =<< annexThawContentCommand <$> Annex.getGitConfig
264  where
265	go basecmd = void $ liftIO $
266		boolSystem "sh" [Param "-c", Param $ gencmd basecmd]
267	gencmd = massReplace [ ("%path", shellEscape (fromRawFilePath p)) ]
268