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
|
{- git-annex file permissions
-
- Copyright 2012 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Annex.Perms (
FileMode,
setAnnexFilePerm,
setAnnexDirPerm,
annexFileMode,
createAnnexDirectory,
noUmask,
freezeContent,
isContentWritePermOk,
thawContent,
chmodContent,
createContentDir,
freezeContentDir,
thawContentDir,
modifyContent,
withShared,
) where
import Annex.Common
import Utility.FileMode
import Git.ConfigTypes
import qualified Annex
import Config
withShared :: (SharedRepository -> Annex a) -> Annex a
withShared a = a =<< coreSharedRepository <$> Annex.getGitConfig
setAnnexFilePerm :: FilePath -> Annex ()
setAnnexFilePerm = setAnnexPerm False
setAnnexDirPerm :: FilePath -> Annex ()
setAnnexDirPerm = setAnnexPerm True
{- Sets appropriate file mode for a file or directory in the annex,
- other than the content files and content directory. Normally,
- use the default mode, but with core.sharedRepository set,
- allow the group to write, etc. -}
setAnnexPerm :: Bool -> FilePath -> Annex ()
setAnnexPerm isdir file = unlessM crippledFileSystem $
withShared $ liftIO . go
where
go GroupShared = void $ tryIO $ modifyFileMode file $ addModes $
groupSharedModes ++
if isdir then [ ownerExecuteMode, groupExecuteMode ] else []
go AllShared = void $ tryIO $ modifyFileMode file $ addModes $
readModes ++
[ ownerWriteMode, groupWriteMode ] ++
if isdir then executeModes else []
go _ = noop
{- Gets the appropriate mode to use for creating a file in the annex
- (other than content files, which are locked down more). -}
annexFileMode :: Annex FileMode
annexFileMode = withShared $ return . go
where
go GroupShared = sharedmode
go AllShared = combineModes (sharedmode:readModes)
go _ = stdFileMode
sharedmode = combineModes groupSharedModes
{- Creates a directory inside the gitAnnexDir, including any parent
- directories. Makes directories with appropriate permissions. -}
createAnnexDirectory :: FilePath -> Annex ()
createAnnexDirectory dir = walk dir [] =<< top
where
top = parentDir <$> fromRepo gitAnnexDir
walk d below stop
| d `equalFilePath` stop = done
| otherwise = ifM (liftIO $ doesDirectoryExist d)
( done
, walk (parentDir d) (d:below) stop
)
where
done = forM_ below $ \p -> do
liftIO $ createDirectoryIfMissing True p
setAnnexDirPerm p
{- Normally, blocks writing to an annexed file, and modifies file
- permissions to allow reading it.
-
- When core.sharedRepository is set, the write bits are not removed from
- the file, but instead the appropriate group write bits are set. This is
- necessary to let other users in the group lock the file. But, in a
- shared repository, the current user may not be able to change a file
- owned by another user, so failure to set this mode is ignored.
-}
freezeContent :: FilePath -> Annex ()
freezeContent file = unlessM crippledFileSystem $
withShared go
where
go GroupShared = liftIO $ void $ tryIO $ modifyFileMode file $
addModes [ownerReadMode, groupReadMode, ownerWriteMode, groupWriteMode]
go AllShared = liftIO $ void $ tryIO $ modifyFileMode file $
addModes (readModes ++ writeModes)
go _ = liftIO $ modifyFileMode file $
removeModes writeModes .
addModes [ownerReadMode]
isContentWritePermOk :: FilePath -> Annex Bool
isContentWritePermOk file = ifM crippledFileSystem
( return True
, withShared go
)
where
go GroupShared = want [ownerWriteMode, groupWriteMode]
go AllShared = want writeModes
go _ = return True
want wantmode =
liftIO (catchMaybeIO $ fileMode <$> getFileStatus file) >>= return . \case
Nothing -> True
Just havemode -> havemode == combineModes (havemode:wantmode)
{- Adjusts read mode of annexed file per core.sharedRepository setting. -}
chmodContent :: FilePath -> Annex ()
chmodContent file = unlessM crippledFileSystem $
withShared go
where
go GroupShared = liftIO $ void $ tryIO $ modifyFileMode file $
addModes [ownerReadMode, groupReadMode]
go AllShared = liftIO $ void $ tryIO $ modifyFileMode file $
addModes readModes
go _ = liftIO $ modifyFileMode file $
addModes [ownerReadMode]
{- Allows writing to an annexed file that freezeContent was called on
- before. -}
thawContent :: FilePath -> Annex ()
thawContent file = thawPerms $ withShared go
where
go GroupShared = liftIO $ void $ tryIO $ groupWriteRead file
go AllShared = liftIO $ void $ tryIO $ groupWriteRead file
go _ = liftIO $ allowWrite file
{- Runs an action that thaws a file's permissions. This will probably
- fail on a crippled filesystem. But, if file modes are supported on a
- crippled filesystem, the file may be frozen, so try to thaw it. -}
thawPerms :: Annex () -> Annex ()
thawPerms a = ifM crippledFileSystem
( void $ tryNonAsync a
, a
)
{- Blocks writing to the directory an annexed file is in, to prevent the
- file accidentally being deleted. However, if core.sharedRepository
- is set, this is not done, since the group must be allowed to delete the
- file.
-}
freezeContentDir :: FilePath -> Annex ()
freezeContentDir file = unlessM crippledFileSystem $
withShared go
where
dir = parentDir file
go GroupShared = liftIO $ void $ tryIO $ groupWriteRead dir
go AllShared = liftIO $ void $ tryIO $ groupWriteRead dir
go _ = liftIO $ preventWrite dir
thawContentDir :: FilePath -> Annex ()
thawContentDir file = thawPerms $ liftIO $ allowWrite $ parentDir file
{- Makes the directory tree to store an annexed file's content,
- with appropriate permissions on each level. -}
createContentDir :: FilePath -> Annex ()
createContentDir dest = do
unlessM (liftIO $ doesDirectoryExist dir) $
createAnnexDirectory dir
-- might have already existed with restricted perms
unlessM crippledFileSystem $
liftIO $ allowWrite dir
where
dir = parentDir dest
{- Creates the content directory for a file if it doesn't already exist,
- or thaws it if it does, then runs an action to modify the file, and
- finally, freezes the content directory. -}
modifyContent :: FilePath -> Annex a -> Annex a
modifyContent f a = do
createContentDir f -- also thaws it
v <- tryNonAsync a
freezeContentDir f
either throwM return v
|
