add: Detect when xattrs or perhaps ACLs prevent locking down a file's content

And fail with an informative message.

I don't think ACLs can prevent removing the write bit, but I'm not sure,
so kept it mentioning them as a possibility.

Should git-annex lock also check if the write bits are able to be removed?
Maybe, but the case I know about with xattrs involves cp -a copying NFS
xattrs, and it's the copy of the file that is the problem. So when locking
a file, I guess it will not be the copy.

Sponsored-by: Dartmouth College's Datalad project

Annex/Ingest.hs

@@ -1,6 +1,6 @@
 {- git-annex content ingestion
  -
- - Copyright 2010-2020 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -51,8 +51,6 @@ import Annex.AdjustedBranch
 import Annex.FileMatcher
 import qualified Utility.RawFilePath as R
 
-import Control.Exception (IOException)
-
 data LockedDown = LockedDown
 	{ lockDownConfig :: LockDownConfig
 	, keySource :: KeySource
@@ -78,7 +76,8 @@ data LockDownConfig = LockDownConfig
  - against some changes, like deletion or overwrite of the file, and
  - allows lsof checks to be done more efficiently when adding a lot of files.
  -
- - Lockdown can fail if a file gets deleted, and Nothing will be returned.
+ - Lockdown can fail if a file gets deleted, or if it's unable to remove
+ - write permissions, and Nothing will be returned.
  -}
 lockDown :: LockDownConfig -> FilePath -> Annex (Maybe LockedDown)
 lockDown cfg file = either 
@@ -86,8 +85,8 @@ lockDown cfg file = either
 		(return . Just)
 	=<< lockDown' cfg file
 
-lockDown' :: LockDownConfig -> FilePath -> Annex (Either IOException LockedDown)
-lockDown' cfg file = tryIO $ ifM crippledFileSystem
+lockDown' :: LockDownConfig -> FilePath -> Annex (Either SomeException LockedDown)
+lockDown' cfg file = tryNonAsync $ ifM crippledFileSystem
 	( nohardlink
 	, case hardlinkFileTmpDir cfg of
 		Nothing -> nohardlink
@@ -96,7 +95,9 @@ lockDown' cfg file = tryIO $ ifM crippledFileSystem
   where
 	file' = toRawFilePath file
 
-	nohardlink = withTSDelta $ liftIO . nohardlink'
+	nohardlink = do
+		setperms
+		withTSDelta $ liftIO . nohardlink'
 
 	nohardlink' delta = do
 		cache <- genInodeCache file' delta
@@ -107,8 +108,7 @@ lockDown' cfg file = tryIO $ ifM crippledFileSystem
 			}
 	
 	withhardlink tmpdir = do
-		when (lockingFile cfg) $
-			freezeContent file'
+		setperms
 		withTSDelta $ \delta -> liftIO $ do
 			(tmpfile, h) <- openTempFile (fromRawFilePath tmpdir) $
 				relatedTemplate $ "ingest-" ++ takeFileName file
@@ -125,6 +125,16 @@ lockDown' cfg file = tryIO $ ifM crippledFileSystem
 			, contentLocation = toRawFilePath tmpfile
 			, inodeCache = cache
 			}
+		
+	setperms = when (lockingFile cfg) $ do
+		freezeContent file'
+		checkContentWritePerm file' >>= \case
+			Just False -> giveup $ unwords
+				[ "Unable to remove all write permissions from"
+				, file
+				, "-- perhaps it has an xattr or ACL set."
+				]
+			_ -> return ()
 
 {- Ingests a locked down file into the annex. Updates the work tree and
  - index. -}

Annex/Perms.hs

@@ -16,7 +16,7 @@ module Annex.Perms (
 	noUmask,
 	freezeContent,
 	freezeContent',
-	isContentWritePermOk,
+	checkContentWritePerm,
 	thawContent,
 	thawContent',
 	createContentDir,
@@ -131,6 +131,12 @@ createWorkTreeDirectory dir = do
  - 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.
+ -
+ - 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 = unlessM crippledFileSystem $
@@ -149,19 +155,34 @@ freezeContent' sr file = do
 		removeModes writeModes .
 		addModes [ownerReadMode]
 
-isContentWritePermOk :: RawFilePath -> Annex Bool
-isContentWritePermOk file = ifM crippledFileSystem
-	( return True
+{- 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.
+ -}
+checkContentWritePerm :: RawFilePath -> Annex (Maybe Bool)
+checkContentWritePerm file = ifM crippledFileSystem
+	( return (Just True)
 	, withShared go
 	)
   where
-	go GroupShared = want [ownerWriteMode, groupWriteMode]
-	go AllShared = want writeModes
-	go _ = return True
-	want wantmode =
+	go GroupShared = want sharedret 
+		(includemodes [ownerWriteMode, groupWriteMode])
+	go AllShared = want sharedret (includemodes writeModes)
+	go _ = want Just (excludemodes writeModes)
+
+	want mk f =
 		liftIO (catchMaybeIO $ fileMode <$> R.getFileStatus file) >>= return . \case
-			Nothing -> True
-			Just havemode -> havemode == combineModes (havemode:wantmode)
+			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. -}