ignore write bits being set when there is a freeze hook

When annex.freezecontent-command is set, and the filesystem does not
support removing write bits, avoid treating it as a crippled filesystem.

The hook may be enough to prevent writing on its own, and some filesystems
ignore attempts to remove write bits.

Sponsored-by: Dartmouth College's Datalad project

Annex/Init.hs

@@ -251,6 +251,7 @@ probeCrippledFileSystem = withEventuallyCleanedOtherTmp $ \tmp -> do
 	(r, warnings) <- probeCrippledFileSystem' tmp
 		(Just (freezeContent' UnShared))
 		(Just (thawContent' UnShared))
+		=<< hasFreezeHook
 	mapM_ warning warnings
 	return r
 
@@ -259,11 +260,12 @@ probeCrippledFileSystem'
 	=> RawFilePath
 	-> Maybe (RawFilePath -> m ())
 	-> Maybe (RawFilePath -> m ())
+	-> Bool
 	-> m (Bool, [String])
 #ifdef mingw32_HOST_OS
-probeCrippledFileSystem' _ _ _ = return (True, [])
+probeCrippledFileSystem' _ _ _ _ = return (True, [])
 #else
-probeCrippledFileSystem' tmp freezecontent thawcontent = do
+probeCrippledFileSystem' tmp freezecontent thawcontent hasfreezehook = do
 	let f = tmp P.</> "gaprobe"
 	let f' = fromRawFilePath f
 	liftIO $ writeFile f' ""
@@ -282,7 +284,7 @@ probeCrippledFileSystem' tmp freezecontent thawcontent = do
 		-- running as root). But some crippled
 		-- filesystems ignore write bit removals or ignore
 		-- permissions entirely.
-		ifM ((== Just False) <$> liftIO (checkContentWritePerm' UnShared (toRawFilePath f) Nothing))
+		ifM ((== Just False) <$> liftIO (checkContentWritePerm' UnShared (toRawFilePath f) Nothing hasfreezehook))
 			( return (True, ["Filesystem does not allow removing write bit from files."])
 			, liftIO $ ifM ((== 0) <$> getRealUserID)
 				( return (False, [])

Annex/Perms.hs

@@ -26,6 +26,7 @@ module Annex.Perms (
 	thawContentDir,
 	modifyContent,
 	withShared,
+	hasFreezeHook,
 ) where
 
 import Annex.Common
@@ -183,17 +184,26 @@ freezeContent'' sr file rv = do
  - 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
-		withShared (\sr -> liftIO (checkContentWritePerm' sr file rv))
+		hasfreezehook <- hasFreezeHook
+		withShared $ \sr -> liftIO $
+			checkContentWritePerm' sr file rv hasfreezehook
 	)
 
-checkContentWritePerm' :: SharedRepository -> RawFilePath -> Maybe RepoVersion -> IO (Maybe Bool)
+checkContentWritePerm' :: SharedRepository -> RawFilePath -> Maybe RepoVersion -> Bool -> IO (Maybe Bool)
-checkContentWritePerm' sr file rv = case sr of
+checkContentWritePerm' sr file rv hasfreezehook
+	| hasfreezehook = return (Just True)
+	| otherwise = case sr of
 		GroupShared
 			| versionNeedsWritableContentFiles rv -> want sharedret
 				(includemodes [ownerWriteMode, groupWriteMode])
@@ -280,6 +290,9 @@ modifyContent f a = do
 	freezeContentDir f
 	either throwM return v
 
+hasFreezeHook :: Annex Bool
+hasFreezeHook = isJust . annexFreezeContentCommand <$> Annex.getGitConfig
+
 freezeHook :: RawFilePath -> Annex ()
 freezeHook p = maybe noop go =<< annexFreezeContentCommand <$> Annex.getGitConfig
   where

CHANGELOG

@@ -6,6 +6,9 @@ git-annex (10.20220223) UNRELEASED; urgency=medium
     be annexed like any other file.
   * smudge: Warn when encountering a pointer file that has other content
     appended to it.
+  * When annex.freezecontent-command is set, and the filesystem does not
+    support removing write bits, avoid treating it as a crippled
+    filesystem.
 
  -- Joey Hess <id@joeyh.name>  Wed, 23 Feb 2022 14:14:09 -0400
 

Test.hs

@@ -145,7 +145,7 @@ runner opts
 		ensuretmpdir
 		crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem'
 			(toRawFilePath tmpdir)
-			Nothing Nothing
+			Nothing Nothing False
 		adjustedbranchok <- Annex.AdjustedBranch.isGitVersionSupported
 		case tryIngredients ingredients (tastyOptionSet opts) (tests crippledfilesystem adjustedbranchok opts) of
 			Nothing -> error "No tests found!?"

doc/bugs/can__39__t_make_annex_happy_in_freeze__47__thaw/comment_5_1bf2ff8d5ddbc8121ea69a5f4042f190._comment

@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 5"""
+ date="2022-02-24T17:24:55Z"
+ content="""
+Fixed it to ignore remaining write perms when annex.freezecontent-command
+is set.
+"""]]

doc/git-annex.mdwn

@@ -1231,8 +1231,10 @@ repository, using [[git-annex-config]]. See its man page for a list.)
 
   Usually the write permission bits are unset to protect annexed objects
   from being modified or deleted. The freezecontent-command is run after
-  git-annex has removed the write bit. The thawcontent-command should undo
+  git-annex has removed (or attempted to remove) the write bit, and can
-  its effect, and is run before git-annex restores the write bit.
+  be used to prevent writing in some other way.
+  The thawcontent-command should undo its effect, and is run before
+  git-annex restores the write bit.
 
   In the command line, %path is replaced with the file or directory to
   operate on.