aff37fc208
This makes annexFileMode be just an application of setAnnexPerm', which avoids having 2 functions that do different versions of the same thing. Fixes some buggy behavior for some combinations of core.sharedRepository and umask. Sponsored-by: Jack Hill on Patreon
374 lines
14 KiB
Haskell
374 lines
14 KiB
Haskell
{- git-annex file permissions
|
|
-
|
|
- Copyright 2012-2023 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Annex.Perms (
|
|
FileMode,
|
|
setAnnexFilePerm,
|
|
setAnnexDirPerm,
|
|
resetAnnexFilePerm,
|
|
annexFileMode,
|
|
createAnnexDirectory,
|
|
createWorkTreeDirectory,
|
|
freezeContent,
|
|
freezeContent',
|
|
freezeContent'',
|
|
checkContentWritePerm,
|
|
checkContentWritePerm',
|
|
thawContent,
|
|
thawContent',
|
|
createContentDir,
|
|
freezeContentDir,
|
|
thawContentDir,
|
|
modifyContentDir,
|
|
modifyContentDirWhenExists,
|
|
withShared,
|
|
hasFreezeHook,
|
|
hasThawHook,
|
|
) where
|
|
|
|
import Annex.Common
|
|
import Utility.FileMode
|
|
import Git
|
|
import Git.ConfigTypes
|
|
import qualified Annex
|
|
import Annex.Version
|
|
import Types.RepoVersion
|
|
import Config
|
|
import Utility.Directory.Create
|
|
import qualified Utility.RawFilePath as R
|
|
|
|
import System.PosixCompat.Files (fileMode, intersectFileModes, nullFileMode, groupWriteMode, ownerWriteMode, ownerReadMode, groupReadMode, otherReadMode, stdFileMode, ownerExecuteMode, groupExecuteMode, otherExecuteMode, setGroupIDMode)
|
|
|
|
withShared :: (SharedRepository -> Annex a) -> Annex a
|
|
withShared a = a =<< coreSharedRepository <$> Annex.getGitConfig
|
|
|
|
setAnnexFilePerm :: RawFilePath -> Annex ()
|
|
setAnnexFilePerm = setAnnexPerm False
|
|
|
|
setAnnexDirPerm :: RawFilePath -> 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,
|
|
- don't change the mode, but with core.sharedRepository set,
|
|
- allow the group to write, etc. -}
|
|
setAnnexPerm :: Bool -> RawFilePath -> Annex ()
|
|
setAnnexPerm isdir file = setAnnexPerm' Nothing isdir >>= \go -> liftIO (go file)
|
|
|
|
setAnnexPerm' :: Maybe ([FileMode] -> FileMode -> FileMode) -> Bool -> Annex (RawFilePath -> IO ())
|
|
setAnnexPerm' modef isdir = ifM crippledFileSystem
|
|
( return (const noop)
|
|
, withShared $ \s -> return $ \file -> go s file
|
|
)
|
|
where
|
|
go GroupShared file = void $ tryIO $ modifyFileMode file $ modef' $
|
|
groupSharedModes ++
|
|
if isdir then [ ownerExecuteMode, groupExecuteMode ] else []
|
|
go AllShared file = void $ tryIO $ modifyFileMode file $ modef' $
|
|
readModes ++
|
|
[ ownerWriteMode, groupWriteMode ] ++
|
|
if isdir then executeModes else []
|
|
go UnShared file = case modef of
|
|
Nothing -> noop
|
|
Just f -> void $ tryIO $
|
|
modifyFileMode file $ f []
|
|
go (UmaskShared n) file = void $ tryIO $ R.setFileMode file $
|
|
if isdir then umaskSharedDirectory n else n
|
|
modef' = fromMaybe addModes modef
|
|
|
|
resetAnnexFilePerm :: RawFilePath -> Annex ()
|
|
resetAnnexFilePerm = resetAnnexPerm False
|
|
|
|
{- Like setAnnexPerm, but ignores the current mode of the file entirely,
|
|
- and sets the same mode that the umask would result in when creating a
|
|
- new file.
|
|
-
|
|
- Useful eg, after creating a temporary file with locked down modes,
|
|
- which is going to be moved to a non-temporary location and needs
|
|
- usual modes.
|
|
-}
|
|
resetAnnexPerm :: Bool -> RawFilePath -> Annex ()
|
|
resetAnnexPerm isdir file = unlessM crippledFileSystem $ do
|
|
defmode <- liftIO defaultFileMode
|
|
let modef moremodes _oldmode = addModes moremodes defmode
|
|
setAnnexPerm' (Just modef) isdir >>= \go -> liftIO (go file)
|
|
|
|
{- Creates a ModeSetter which can be used for creating a file in the annex
|
|
- (other than content files, which are locked down more). -}
|
|
annexFileMode :: Annex ModeSetter
|
|
annexFileMode = do
|
|
modesetter <- setAnnexPerm' Nothing False
|
|
withShared (\s -> pure $ mk s modesetter)
|
|
where
|
|
mk GroupShared = ModeSetter stdFileMode
|
|
mk AllShared = ModeSetter stdFileMode
|
|
mk UnShared = ModeSetter stdFileMode
|
|
mk (UmaskShared mode) = ModeSetter mode
|
|
|
|
{- Creates a directory inside the gitAnnexDir (or possibly the dbdir),
|
|
- creating any parent directories up to and including the gitAnnexDir.
|
|
- Makes directories with appropriate permissions. -}
|
|
createAnnexDirectory :: RawFilePath -> Annex ()
|
|
createAnnexDirectory dir = do
|
|
top <- parentDir <$> fromRepo gitAnnexDir
|
|
tops <- annexDbDir <$> Annex.getGitConfig >>= return . \case
|
|
Nothing -> [top]
|
|
Just dbdir -> [top, parentDir (parentDir dbdir)]
|
|
createDirectoryUnder' tops dir createdir
|
|
where
|
|
createdir p = do
|
|
liftIO $ R.createDirectory p
|
|
setAnnexDirPerm p
|
|
|
|
{- Create a directory in the git work tree, creating any parent
|
|
- directories up to the top of the work tree.
|
|
-
|
|
- Uses default permissions.
|
|
-}
|
|
createWorkTreeDirectory :: RawFilePath -> Annex ()
|
|
createWorkTreeDirectory dir = do
|
|
fromRepo repoWorkTree >>= liftIO . \case
|
|
Just wt -> createDirectoryUnder [wt] dir
|
|
-- Should never happen, but let whatever tries to write
|
|
-- to the directory be what throws an exception, as that
|
|
-- will be clearer than an exception from here.
|
|
Nothing -> noop
|
|
|
|
{- Normally, blocks writing to an annexed file, and modifies file
|
|
- permissions to allow reading it.
|
|
-
|
|
- Before v9, 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.
|
|
- v9 improved this by using separate lock files, so the content file does
|
|
- not need to be writable when using it.
|
|
-
|
|
- In a shared repository, the current user may not be able to change
|
|
- a file owned by another user, so failure to change modes is ignored.
|
|
-
|
|
- Note that, on Linux, xattrs can sometimes prevent removing
|
|
- certain permissions from a file with chmod. (Maybe some ACLs too?)
|
|
- In such a case, this will return with the file still having some mode
|
|
- it should not normally have. checkContentWritePerm can detect when
|
|
- that happens with write permissions.
|
|
-}
|
|
freezeContent :: RawFilePath -> Annex ()
|
|
freezeContent file =
|
|
withShared $ \sr -> freezeContent' sr file
|
|
|
|
freezeContent' :: SharedRepository -> RawFilePath -> Annex ()
|
|
freezeContent' sr file = freezeContent'' sr file =<< getVersion
|
|
|
|
freezeContent'' :: SharedRepository -> RawFilePath -> Maybe RepoVersion -> Annex ()
|
|
freezeContent'' sr file rv = do
|
|
fastDebug "Annex.Perms" ("freezing content " ++ fromRawFilePath file)
|
|
unlessM crippledFileSystem $ go sr
|
|
freezeHook file
|
|
where
|
|
go UnShared = liftIO $ nowriteadd [ownerReadMode]
|
|
go GroupShared = if versionNeedsWritableContentFiles rv
|
|
then liftIO $ ignoresharederr $ modmode $ addModes
|
|
[ownerReadMode, groupReadMode, ownerWriteMode, groupWriteMode]
|
|
else liftIO $ ignoresharederr $
|
|
nowriteadd [ownerReadMode, groupReadMode]
|
|
go AllShared = if versionNeedsWritableContentFiles rv
|
|
then liftIO $ ignoresharederr $ modmode $ addModes
|
|
(readModes ++ writeModes)
|
|
else liftIO $ ignoresharederr $
|
|
nowriteadd readModes
|
|
go (UmaskShared n) = if versionNeedsWritableContentFiles rv
|
|
-- Assume that the configured mode includes write bits
|
|
-- for all users who should be able to lock the file, so
|
|
-- don't need to add any write modes.
|
|
then liftIO $ ignoresharederr $ modmode $ const n
|
|
else liftIO $ ignoresharederr $ modmode $ const $
|
|
removeModes writeModes n
|
|
|
|
ignoresharederr = void . tryIO
|
|
|
|
modmode = modifyFileMode file
|
|
|
|
nowriteadd readmodes = modmode $
|
|
removeModes writeModes .
|
|
addModes readmodes
|
|
|
|
{- Checks if the write permissions are as freezeContent should set them.
|
|
-
|
|
- When the repository is shared, the user may not be able to change
|
|
- permissions of a file owned by another user. So if the permissions seem
|
|
- wrong, but the repository is shared, returns Nothing. If the permissions
|
|
- are wrong otherwise, returns Just False.
|
|
-
|
|
- When there is a freeze hook, it may prevent write in some way other than
|
|
- permissions. One use of a freeze hook is when the filesystem does not
|
|
- support removing write permissions, so when there is such a hook
|
|
- write permissions are ignored.
|
|
-}
|
|
checkContentWritePerm :: RawFilePath -> Annex (Maybe Bool)
|
|
checkContentWritePerm file = ifM crippledFileSystem
|
|
( return (Just True)
|
|
, do
|
|
rv <- getVersion
|
|
hasfreezehook <- hasFreezeHook
|
|
withShared $ \sr ->
|
|
liftIO $ checkContentWritePerm' sr file rv hasfreezehook
|
|
)
|
|
|
|
checkContentWritePerm' :: SharedRepository -> RawFilePath -> Maybe RepoVersion -> Bool -> IO (Maybe Bool)
|
|
checkContentWritePerm' sr file rv hasfreezehook
|
|
| hasfreezehook = return (Just True)
|
|
| otherwise = case sr of
|
|
UnShared -> want Just (excludemodes writeModes)
|
|
GroupShared
|
|
| versionNeedsWritableContentFiles rv -> want sharedret
|
|
(includemodes [ownerWriteMode, groupWriteMode])
|
|
| otherwise -> want sharedret (excludemodes writeModes)
|
|
AllShared
|
|
| versionNeedsWritableContentFiles rv ->
|
|
want sharedret (includemodes writeModes)
|
|
| otherwise -> want sharedret (excludemodes writeModes)
|
|
UmaskShared n
|
|
| versionNeedsWritableContentFiles rv -> want sharedret
|
|
(\havemode -> havemode == n)
|
|
| otherwise -> want sharedret
|
|
(\havemode -> havemode == removeModes writeModes n)
|
|
where
|
|
want mk f = catchMaybeIO (fileMode <$> R.getFileStatus file)
|
|
>>= return . \case
|
|
Just havemode -> mk (f havemode)
|
|
Nothing -> mk True
|
|
|
|
includemodes l havemode = havemode == combineModes (havemode:l)
|
|
excludemodes l havemode = all (\m -> intersectFileModes m havemode == nullFileMode) l
|
|
|
|
sharedret True = Just True
|
|
sharedret False = Nothing
|
|
|
|
{- Allows writing to an annexed file that freezeContent was called on
|
|
- before. -}
|
|
thawContent :: RawFilePath -> Annex ()
|
|
thawContent file = withShared $ \sr -> thawContent' sr file
|
|
|
|
thawContent' :: SharedRepository -> RawFilePath -> Annex ()
|
|
thawContent' sr file = do
|
|
fastDebug "Annex.Perms" ("thawing content " ++ fromRawFilePath file)
|
|
thawPerms (go sr) (thawHook file)
|
|
where
|
|
go GroupShared = liftIO $ void $ tryIO $ groupWriteRead file
|
|
go AllShared = liftIO $ void $ tryIO $ groupWriteRead file
|
|
go UnShared = liftIO $ allowWrite file
|
|
go (UmaskShared n) = liftIO $ void $ tryIO $ R.setFileMode file n
|
|
|
|
{- 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 its
|
|
- permissions. -}
|
|
thawPerms :: Annex () -> Annex () -> Annex ()
|
|
thawPerms a hook = ifM crippledFileSystem
|
|
( hook >> void (tryNonAsync a)
|
|
, hook >> 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 without eing able to thaw the directory.
|
|
-}
|
|
freezeContentDir :: RawFilePath -> Annex ()
|
|
freezeContentDir file = do
|
|
fastDebug "Annex.Perms" ("freezing content directory " ++ fromRawFilePath dir)
|
|
unlessM crippledFileSystem $ withShared go
|
|
freezeHook dir
|
|
where
|
|
dir = parentDir file
|
|
go UnShared = liftIO $ preventWrite dir
|
|
go GroupShared = liftIO $ void $ tryIO $ groupWriteRead dir
|
|
go AllShared = liftIO $ void $ tryIO $ groupWriteRead dir
|
|
go (UmaskShared n) = liftIO $ void $ tryIO $ R.setFileMode dir $
|
|
umaskSharedDirectory $
|
|
-- If n includes group or other write mode, leave them set
|
|
-- to allow them to delete the file without being able to
|
|
-- thaw the directory.
|
|
removeModes [ownerWriteMode] n
|
|
|
|
thawContentDir :: RawFilePath -> Annex ()
|
|
thawContentDir file = do
|
|
fastDebug "Annex.Perms" ("thawing content directory " ++ fromRawFilePath dir)
|
|
thawPerms (withShared (liftIO . go)) (thawHook dir)
|
|
where
|
|
dir = parentDir file
|
|
go UnShared = allowWrite dir
|
|
go GroupShared = allowWrite dir
|
|
go AllShared = allowWrite dir
|
|
go (UmaskShared n) = R.setFileMode dir n
|
|
|
|
{- Makes the directory tree to store an annexed file's content,
|
|
- with appropriate permissions on each level. -}
|
|
createContentDir :: RawFilePath -> Annex ()
|
|
createContentDir dest = do
|
|
unlessM (liftIO $ R.doesPathExist dir) $
|
|
createAnnexDirectory dir
|
|
-- might have already existed with restricted perms
|
|
thawHook dir
|
|
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 a file in the
|
|
- directory, and finally, freezes the content directory. -}
|
|
modifyContentDir :: RawFilePath -> Annex a -> Annex a
|
|
modifyContentDir f a = do
|
|
createContentDir f -- also thaws it
|
|
v <- tryNonAsync a
|
|
freezeContentDir f
|
|
either throwM return v
|
|
|
|
{- Like modifyContentDir, but avoids creating the content directory if it
|
|
- does not already exist. In that case, the action will probably fail. -}
|
|
modifyContentDirWhenExists :: RawFilePath -> Annex a -> Annex a
|
|
modifyContentDirWhenExists f a = do
|
|
thawContentDir f
|
|
v <- tryNonAsync a
|
|
freezeContentDir f
|
|
either throwM return v
|
|
|
|
hasFreezeHook :: Annex Bool
|
|
hasFreezeHook = isJust . annexFreezeContentCommand <$> Annex.getGitConfig
|
|
|
|
hasThawHook :: Annex Bool
|
|
hasThawHook = isJust . annexThawContentCommand <$> Annex.getGitConfig
|
|
|
|
freezeHook :: RawFilePath -> Annex ()
|
|
freezeHook p = maybe noop go =<< annexFreezeContentCommand <$> Annex.getGitConfig
|
|
where
|
|
go basecmd = void $ liftIO $
|
|
boolSystem "sh" [Param "-c", Param $ gencmd basecmd]
|
|
gencmd = massReplace [ ("%path", shellEscape (fromRawFilePath p)) ]
|
|
|
|
thawHook :: RawFilePath -> Annex ()
|
|
thawHook p = maybe noop go =<< annexThawContentCommand <$> Annex.getGitConfig
|
|
where
|
|
go basecmd = void $ liftIO $
|
|
boolSystem "sh" [Param "-c", Param $ gencmd basecmd]
|
|
gencmd = massReplace [ ("%path", shellEscape (fromRawFilePath p)) ]
|
|
|
|
{- Calculate mode to use for a directory from the mode to use for a file.
|
|
-
|
|
- This corresponds to git's handling of core.sharedRepository=0xxx
|
|
-}
|
|
umaskSharedDirectory :: FileMode -> FileMode
|
|
umaskSharedDirectory n = flip addModes n $ map snd $ filter fst
|
|
[ (isset ownerReadMode, ownerExecuteMode)
|
|
, (isset groupReadMode, groupExecuteMode)
|
|
, (isset otherReadMode, otherExecuteMode)
|
|
, (isset groupReadMode || isset groupWriteMode, setGroupIDMode)
|
|
]
|
|
where
|
|
isset v = checkMode v n
|