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
-	let f = fromRawFilePath (tmp P.</> "gaprobe")
-	writeFile f ""
-	r <- probe f
-	void $ tryIO $ allowWrite (toRawFilePath f)
-	removeFile f
+probeCrippledFileSystem' tmp freezecontent thawcontent = do
+	let f = tmp P.</> "gaprobe"
+	let f' = fromRawFilePath f
+	liftIO $ writeFile f' ""
+	r <- probe 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)
-		createSymbolicLink f f2
-		removeWhenExistsWith R.removeLink (toRawFilePath f2)
-		preventWrite (toRawFilePath f)
+		liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f2)
+		liftIO $ createSymbolicLink f f2
+		liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f2)
+		(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. -}