Added annex.freezecontent-command and annex.thawcontent-command configs

Freeze first sets the file perms, and then runs
freezecontent-command. Thaw runs thawcontent-command before
restoring file permissions. This is in case the freeze command
prevents changing file perms, as eg setting a file immutable does.
Also, changing file perms tends to mess up previously set ACLs.

git-annex init's probe for crippled filesystem uses them, so if file perms
don't work, but freezecontent-command manages to prevent write to a file,
it won't treat the filesystem as crippled.

When the the filesystem has been probed as crippled, the hooks are not
used, because there seems to be no point then; git-annex won't be relying
on locking annex objects down. Also, this avoids them being run when the
file perms have not been changed, in case they somehow rely on
git-annex's setting of the file perms in order to work.

Sponsored-by: Dartmouth College's Datalad project

Annex/Init.hs

@@ -1,6 +1,6 @@
 {- git-annex repository initialization
  -
- - Copyright 2011-2020 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2021 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -59,6 +59,7 @@ import qualified Utility.LockFile.Posix as Posix
 #endif
 
 import qualified Data.Map as M
+import Control.Monad.IO.Class (MonadIO)
 #ifndef mingw32_HOST_OS
 import Data.Either
 import qualified System.FilePath.ByteString as P
@@ -241,32 +242,40 @@ isInitialized = maybe Annex.Branch.hasSibling (const $ return True) =<< getVersi
  - or removing write access from files. -}
 probeCrippledFileSystem :: Annex Bool
 probeCrippledFileSystem = withEventuallyCleanedOtherTmp $ \tmp -> do
-	(r, warnings) <- liftIO $ probeCrippledFileSystem' tmp
+	(r, warnings) <- probeCrippledFileSystem' tmp
+		(Just freezeContent)
+		(Just thawContent)
 	mapM_ warning warnings
 	return r
 
-probeCrippledFileSystem' :: RawFilePath -> IO (Bool, [String])
+probeCrippledFileSystem'
+	:: (MonadIO m, MonadCatch m)
+	=> RawFilePath
+	-> Maybe (RawFilePath -> m ())
+	-> Maybe (RawFilePath -> m ())
+	-> m (Bool, [String])
 #ifdef mingw32_HOST_OS
-probeCrippledFileSystem' _ = return (True, [])
+probeCrippledFileSystem' _ _ = return (True, [])
 #else
-probeCrippledFileSystem' tmp = do
+probeCrippledFileSystem' tmp freezecontent thawcontent = do
-	let f = fromRawFilePath (tmp P.</> "gaprobe")
+	let f = tmp P.</> "gaprobe"
-	writeFile f ""
+	let f' = fromRawFilePath f
-	r <- probe f
+	liftIO $ writeFile f' ""
-	void $ tryIO $ allowWrite (toRawFilePath f)
+	r <- probe f'
-	removeFile f
+	void $ tryNonAsync $ (fromMaybe (liftIO . allowWrite) thawcontent) f
+	liftIO $ removeFile f'
 	return r
   where
 	probe f = catchDefaultIO (True, []) $ do
 		let f2 = f ++ "2"
-		removeWhenExistsWith R.removeLink (toRawFilePath f2)
+		liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f2)
-		createSymbolicLink f f2
+		liftIO $ createSymbolicLink f f2
-		removeWhenExistsWith R.removeLink (toRawFilePath f2)
+		liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f2)
-		preventWrite (toRawFilePath f)
+		(fromMaybe (liftIO . preventWrite) freezecontent) (toRawFilePath f)
 		-- Should be unable to write to the file, unless
 		-- running as root, but some crippled
 		-- filesystems ignore write bit removals.
-		ifM ((== 0) <$> getRealUserID)
+		liftIO $ ifM ((== 0) <$> getRealUserID)
 			( return (False, [])
 			, do
 				r <- catchBoolIO $ do
@@ -283,7 +292,8 @@ checkCrippledFileSystem = whenM probeCrippledFileSystem $ do
 	warning "Detected a crippled filesystem."
 	setCrippledFileSystem True
 
-	{- Normally git disables core.symlinks itself when the
+	{- Normally git disables core.symlinks itself when the:w
+	 -
 	 - filesystem does not support them. But, even if symlinks are
 	 - supported, we don't use them by default in a crippled
 	 - filesystem. -}

Annex/Perms.hs

@@ -1,6 +1,6 @@
 {- git-annex file permissions
  -
- - Copyright 2012-2020 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2021 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -131,8 +131,9 @@ createWorkTreeDirectory dir = do
  - owned by another user, so failure to set this mode is ignored.
  -}
 freezeContent :: RawFilePath -> Annex ()
-freezeContent file = unlessM crippledFileSystem $
+freezeContent file = unlessM crippledFileSystem $ do
 	withShared go
+	freezeHook file
   where
 	go GroupShared = liftIO $ void $ tryIO $ modifyFileMode file $
 		addModes [ownerReadMode, groupReadMode, ownerWriteMode, groupWriteMode]
@@ -159,7 +160,7 @@ isContentWritePermOk file = ifM crippledFileSystem
 {- Allows writing to an annexed file that freezeContent was called on
  - before. -}
 thawContent :: RawFilePath -> Annex ()
-thawContent file = thawPerms $ withShared go
+thawContent file = thawPerms (withShared go) (thawHook file)
   where
 	go GroupShared = liftIO $ void $ tryIO $ groupWriteRead file
 	go AllShared = liftIO $ void $ tryIO $ groupWriteRead file
@@ -167,11 +168,12 @@ thawContent file = thawPerms $ withShared go
 
 {- 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. -}
+ - crippled filesystem, the file may be frozen, so try to thaw its
-thawPerms :: Annex () -> Annex ()
+ - permissions. -}
-thawPerms a = ifM crippledFileSystem
+thawPerms :: Annex () -> Annex () -> Annex ()
-	( void $ tryNonAsync a
+thawPerms a hook = ifM crippledFileSystem
-	, a
+	( void (tryNonAsync a)
+	, hook >> a
 	)
 
 {- Blocks writing to the directory an annexed file is in, to prevent the
@@ -180,8 +182,9 @@ thawPerms a = ifM crippledFileSystem
  - file.
  -}
 freezeContentDir :: RawFilePath -> Annex ()
-freezeContentDir file = unlessM crippledFileSystem $
+freezeContentDir file = unlessM crippledFileSystem $ do
 	withShared go
+	freezeHook dir
   where
 	dir = parentDir file
 	go GroupShared = liftIO $ void $ tryIO $ groupWriteRead dir
@@ -189,8 +192,9 @@ freezeContentDir file = unlessM crippledFileSystem $
 	go _ = liftIO $ preventWrite dir
 
 thawContentDir :: RawFilePath -> Annex ()
-thawContentDir file = 
+thawContentDir file = thawPerms (liftIO $ allowWrite dir) (thawHook dir)
-	thawPerms $ liftIO $ allowWrite $ parentDir file
+  where
+	dir = parentDir file
 
 {- Makes the directory tree to store an annexed file's content,
  - with appropriate permissions on each level. -}
@@ -199,7 +203,8 @@ createContentDir dest = do
 	unlessM (liftIO $ R.doesPathExist dir) $
 		createAnnexDirectory dir 
 	-- might have already existed with restricted perms
-	unlessM crippledFileSystem $
+	unlessM crippledFileSystem $ do
+		thawHook dir
 		liftIO $ allowWrite dir
   where
 	dir = parentDir dest
@@ -213,3 +218,17 @@ modifyContent f a = do
 	v <- tryNonAsync a
 	freezeContentDir f
 	either throwM return v
+
+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)) ]

CHANGELOG

@@ -3,6 +3,8 @@ git-annex (8.20210622) UNRELEASED; urgency=medium
   * sync: Partly work around github behavior that first branch to be pushed
     to a new repository is assumed to be the head branch, by not pushing
     synced/git-annex first.
+  * Added annex.freezecontent-command and annex.thawcontent-command
+    configs.
 
  -- Joey Hess <id@joeyh.name>  Mon, 21 Jun 2021 12:25:25 -0400
 

Test.hs

@@ -142,7 +142,9 @@ runner opts
 		exitWith exitcode
 	runsubprocesstests (Just _) = isolateGitConfig $ do
 		ensuretmpdir
-		crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem' (toRawFilePath tmpdir)
+		crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem'
+			(toRawFilePath tmpdir)
+			Nothing Nothing
 		adjustedbranchok <- Annex.AdjustedBranch.isGitVersionSupported
 		case tryIngredients ingredients (tastyOptionSet opts) (tests crippledfilesystem adjustedbranchok opts) of
 			Nothing -> error "No tests found!?"

Types/GitConfig.hs

@@ -104,6 +104,8 @@ data GitConfig = GitConfig
 	, annexFsckNudge :: Bool
 	, annexAutoUpgrade :: AutoUpgrade
 	, annexExpireUnused :: Maybe (Maybe Duration)
+	, annexFreezeContentCommand :: Maybe String
+	, annexThawContentCommand :: Maybe String
 	, annexSecureEraseCommand :: Maybe String
 	, annexGenMetaData :: Bool
 	, annexListen :: Maybe String
@@ -191,6 +193,8 @@ extractGitConfig configsource r = GitConfig
 		getmaybe (annexConfig "autoupgrade")
 	, annexExpireUnused = either (const Nothing) Just . parseDuration
 		<$> getmaybe (annexConfig "expireunused")
+	, annexFreezeContentCommand = getmaybe (annexConfig "freezecontent-command")
+	, annexThawContentCommand = getmaybe (annexConfig "thawcontent-command")
 	, annexSecureEraseCommand = getmaybe (annexConfig "secure-erase-command")
 	, annexGenMetaData = getbool (annexConfig "genmetadata") False
 	, annexListen = getmaybe (annexConfig "listen")

doc/git-annex.mdwn

@@ -1213,6 +1213,16 @@ repository, using [[git-annex-config]]. See its man page for a list.)
 
   For example, to use the wipe command, set it to `wipe -f %file`.
 
+* `annex.freezecontent-command`, `annex.thawcontent-command`
+
+  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
+  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.
+
 * `annex.tune.objecthash1`, `annex.tune.objecthashlower`, `annex.tune.branchhash1`
 
   These can be passed to `git annex init` to tune the repository.

doc/internals/lockdown.mdwn

@@ -42,3 +42,7 @@ it is that if you explicitly run `chmod +w` on an annexed file in the working
 tree, this follows the symlink and allows writing to the file. It would be
 better to make the files fully immutable. But most systems either don't
 support immutable attributes, or only let root make files immutable.
+
+The git configs `annex.freezecontent-command` and `annex.thawcontent-command`
+can be used to run additional commands to further lock down and later thaw
+the annex object and directory.

doc/todo/lockdown_hooks.mdwn

@@ -15,7 +15,7 @@ Use cases include:
 
 Design:
 
-Configs: annex.lockdown-command, annex.unlockdown-command
+Configs: annex.freezecontent-command, annex.thawcontent-command
 In these, "%path" is replaced with the file/directory to act on.
 
 Locking down a directory only needs to do the equivilant of removing its
@@ -49,5 +49,11 @@ fed the names of files to operate on via stdin.
 > hook could also support things like [[storing_xattrs|support_for_storing_xattrs]]
 > --[[Joey]]
 
-[[!tag needsthought]]
 [[!tag projects/datalad]]
+
+> [[done]].. `git-annex init` does run annex.freezecontent-command and if it
+> prevents writing to a file, it will avoid setting
+> annex.crippledfilesystem.
+> 
+> I didn't make `git-annex test` use the global git config of the hooks
+> though, not sure if that really makes sense or is needed.