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