Support git's core.sharedRepository configuration

This is incomplete, it does not honor it yet for hash directories
and other annex bookkeeping files. Some of that is not needed for a bare
repo; some of it may be.

Annex/Content.hs

@@ -23,10 +23,11 @@ module Annex.Content (
 	saveState,
 	downloadUrl,
 	preseedTmp,
+	freezeContent,
+	thawContent,
+	freezeContentDir,
 ) where
 
-import Control.Exception (bracket_)
-import System.Posix.Types
 import System.IO.Unsafe (unsafeInterleaveIO)
 
 import Common.Annex
@@ -44,6 +45,7 @@ import Utility.DataUnits
 import Utility.CopyFile
 import Config
 import Annex.Exception
+import Git.SharedRepository
 
 {- Checks if a given key's content is currently present. -}
 inAnnex :: Key -> Annex Bool
@@ -57,8 +59,10 @@ inAnnex' a key = do
 {- A safer check; the key's content must not only be present, but
  - is not in the process of being removed. -}
 inAnnexSafe :: Key -> Annex (Maybe Bool)
-inAnnexSafe = inAnnex' $ \f -> openForLock f False >>= check
+inAnnexSafe = inAnnex' $ \f -> openforlock f >>= check
 	where
+		openforlock f = catchMaybeIO $
+			openFd f ReadOnly Nothing defaultFileFlags
 		check Nothing = return is_missing
 		check (Just h) = do
 			v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)
@@ -75,30 +79,27 @@ inAnnexSafe = inAnnex' $ \f -> openForLock f False >>= check
 lockContent :: Key -> Annex a -> Annex a
 lockContent key a = do
 	file <- inRepo $ gitAnnexLocation key
-	bracketIO (openForLock file True >>= lock) unlock a
+	bracketIO (openforlock file >>= lock) unlock a
 	where
+		{- Since files are stored with the write bit disabled, have
+		 - to fiddle with permissions to open for an exclusive lock. -}
+		openforlock f = catchMaybeIO $ ifM (doesFileExist f)
+			( withModifiedFileMode f
+				(\cur -> cur `unionFileModes` ownerWriteMode)
+				open
+			, open
+			)
+			where
+				open = openFd f ReadWrite Nothing defaultFileFlags
 		lock Nothing = return Nothing
-		lock (Just l) = do
-			v <- tryIO $ setLock l (WriteLock, AbsoluteSeek, 0, 0)
+		lock (Just fd) = do
+			v <- tryIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
 			case v of
 				Left _ -> error "content is locked"
-				Right _ -> return $ Just l
+				Right _ -> return $ Just fd
 		unlock Nothing = return ()
 		unlock (Just l) = closeFd l
 
-openForLock :: FilePath -> Bool -> IO (Maybe Fd)
-openForLock file writelock = bracket_ prep cleanup go
-	where
-		go = catchMaybeIO $ openFd file mode Nothing defaultFileFlags
-		mode = if writelock then ReadWrite else ReadOnly
-		{- Since files are stored with the write bit disabled,
-		 - have to fiddle with permissions to open for an
-		 - exclusive lock. -}
-		forwritelock a = 
-			when writelock $ whenM (doesFileExist file) a
-		prep = forwritelock $ allowWrite file
-		cleanup = forwritelock $ preventWrite file
-
 {- Calculates the relative path to use to link a file to a key. -}
 calcGitLink :: FilePath -> Key -> Annex FilePath
 calcGitLink file key = do
@@ -132,7 +133,7 @@ getViaTmp key action = do
 		else return 0
 	ifM (checkDiskSpace Nothing key alreadythere)
 		( do
-			when e $ liftIO $ allowWrite tmp
+			when e $ thawContent tmp
 			getViaTmpUnchecked key action
 		, return False
 		)
@@ -216,14 +217,15 @@ moveAnnex :: Key -> FilePath -> Annex ()
 moveAnnex key src = do
 	dest <- inRepo $ gitAnnexLocation key
 	let dir = parentDir dest
-	liftIO $ ifM (doesFileExist dest)
-		( removeFile src
+	ifM (liftIO $ doesFileExist dest)
+		( liftIO $ removeFile src
 		, do
-			createDirectoryIfMissing True dir
-			allowWrite dir -- in case the directory already exists
-			moveFile src dest
-			preventWrite dest
-			preventWrite dir
+			liftIO $ do
+				createDirectoryIfMissing True dir
+				allowWrite dir -- in case the directory already exists
+				moveFile src dest
+			freezeContent dest
+			freezeContentDir dest
 		)
 
 withObjectLoc :: Key -> ((FilePath, FilePath) -> Annex a) -> Annex a
@@ -254,10 +256,9 @@ removeAnnex key = withObjectLoc key $ \(dir, file) -> do
 {- Moves a key's file out of .git/annex/objects/ -}
 fromAnnex :: Key -> FilePath -> Annex ()
 fromAnnex key dest = withObjectLoc key $ \(dir, file) -> do
-	liftIO $ do
-		allowWrite dir
-		allowWrite file
-		moveFile file dest
+	liftIO $ allowWrite dir
+	thawContent file
+	liftIO $ moveFile file dest
 	cleanObjectLoc key
 
 {- Moves a key out of .git/annex/objects/ into .git/annex/bad, and
@@ -321,7 +322,7 @@ preseedTmp key file = go =<< inAnnex key
 		go False = return False
 		go True = do
 			ok <- copy
-			when ok $ liftIO $ allowWrite file
+			when ok $ thawContent file
 			return ok
 		copy = ifM (liftIO $ doesFileExist file)
 				( return True
@@ -329,3 +330,40 @@ preseedTmp key file = go =<< inAnnex key
 					s <- inRepo $ gitAnnexLocation key
 					liftIO $ copyFileExternal s file
 				)
+
+{- Blocks writing to an annexed file. The file is made unwritable
+ - to avoid accidental edits. core.sharedRepository may change
+ - who can read it. -}
+freezeContent :: FilePath -> Annex ()
+freezeContent file = liftIO . go =<< fromRepo getSharedRepository
+	where
+		go GroupShared = do
+			preventWrite file
+			groupRead file
+		go AllShared = do
+			preventWrite file
+			allRead file
+		go _ = preventWrite file
+
+{- Allows writing to an annexed file that freezeContent was called on
+ - before. -}
+thawContent :: FilePath -> Annex ()
+thawContent file = liftIO . go =<< fromRepo getSharedRepository
+	where
+		go GroupShared = groupWriteRead file
+		go AllShared = groupWriteRead file
+		go _ = allowWrite file
+
+{- Blocks writing to the directory an annexed file is in, to prevent the
+ - file accidentially being deleted. However, if core.sharedRepository
+ - is set, this is not done, since the group must be allowed to delete the
+ - file.
+ -}
+freezeContentDir :: FilePath -> Annex ()
+freezeContentDir file = liftIO . go =<< fromRepo getSharedRepository
+	where
+		dir = parentDir file
+		go GroupShared = groupWriteRead dir
+		go AllShared = groupWriteRead dir
+		go _ = preventWrite dir
+

Command/Fsck.hs

@@ -166,10 +166,9 @@ verifyLocationLog key desc = do
 	-- Since we're checking that a key's file is present, throw
 	-- in a permission fixup here too.
 	when present $ do
-		f <- inRepo $ gitAnnexLocation key
-		liftIO $ do
-			preventWrite f
-			preventWrite (parentDir f)
+		file <- inRepo $ gitAnnexLocation key
+		freezeContent file
+		freezeContentDir file
 
 	u <- getUUID
 	verifyLocationLog' key desc present u (logChange key u)

Command/Unannex.hs

@@ -10,7 +10,6 @@ module Command.Unannex where
 import Common.Annex
 import Command
 import qualified Annex
-import Utility.FileMode
 import Logs.Location
 import Annex.Content
 import qualified Git.Command
@@ -51,9 +50,8 @@ cleanup file key = do
 		( do
 			-- fast mode: hard link to content in annex
 			src <- inRepo $ gitAnnexLocation key
-			liftIO $ do
-				createLink src file
-				allowWrite file
+			liftIO $ createLink src file
+			thawContent file
 		, do
 			fromAnnex key file
 			logStatus key InfoMissing

Command/Unlock.hs

@@ -46,6 +46,6 @@ perform dest key = do
 			liftIO $ do
 				removeFile dest
 				moveFile tmpdest dest
-				allowWrite dest
+			thawContent dest
 			next $ return True
                 else error "copy failed!"

Git/SharedRepository.hs

@@ -0,0 +1,27 @@
+{- git core.sharedRepository handling
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.SharedRepository where
+
+import Data.Char
+
+import Common
+import Git
+import qualified Git.Config
+
+data SharedRepository = UnShared | GroupShared | AllShared | UmaskShared Int
+
+getSharedRepository :: Repo -> SharedRepository
+getSharedRepository r =
+	case map toLower $ Git.Config.get "core.sharedrepository" "" r of
+		"1" -> GroupShared
+		"group" -> GroupShared
+		"true" -> GroupShared
+		"all" -> AllShared
+		"world" -> AllShared
+		"everybody" -> AllShared
+		v -> maybe UnShared UmaskShared (readish v)

Utility/FileMode.hs

@@ -1,6 +1,6 @@
 {- File mode utilities.
  -
- - Copyright 2010 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -9,16 +9,36 @@ module Utility.FileMode where
 
 import Common
 
+import Control.Exception (bracket)
 import System.Posix.Types
 import Foreign (complement)
 
+combineModes :: [FileMode] -> FileMode
+combineModes [] = undefined
+combineModes [m] = m
+combineModes (m:ms) = foldl unionFileModes m ms
+
+{- Applies a conversion function to a file's mode. -}
 modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO ()
 modifyFileMode f convert = do
+	_ <- modifyFileMode' f convert
+	return ()
+modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode
+modifyFileMode' f convert = do
 	s <- getFileStatus f
-	let cur = fileMode s
-	let new = convert cur
-	when (new /= cur) $
+	let old = fileMode s
+	let new = convert old
+	when (new /= old) $
 		setFileMode f new
+	return old
+
+{- Runs an action after changing a file's mode, then restores the old mode. -}
+withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a
+withModifiedFileMode file convert a = bracket setup cleanup go
+	where
+		setup = modifyFileMode' file convert
+		cleanup oldmode = modifyFileMode file (const oldmode)
+		go _ = a
 
 {- Removes a FileMode from a file.
  - For example, call with otherWriteMode to chmod o-w -}
@@ -28,23 +48,43 @@ unsetFileMode f m = modifyFileMode f $
 
 {- Removes the write bits from a file. -}
 preventWrite :: FilePath -> IO ()
-preventWrite f = unsetFileMode f writebits
+preventWrite f = unsetFileMode f $ combineModes writebits
 	where
-		writebits = foldl unionFileModes ownerWriteMode
-					[groupWriteMode, otherWriteMode]
+		writebits = [ownerWriteMode, groupWriteMode, otherWriteMode]
 
 {- Turns a file's write bit back on. -}
 allowWrite :: FilePath -> IO ()
 allowWrite f = modifyFileMode f $
 	\cur -> cur `unionFileModes` ownerWriteMode
 
+{- Allows owner and group to read and write to a file. -}
+groupWriteRead :: FilePath -> IO ()
+groupWriteRead f = modifyFileMode f $ \cur -> combineModes
+	[ cur
+	, ownerWriteMode, groupWriteMode
+	, ownerReadMode, groupReadMode
+	]
+
+{- Allows group to read a file. -}
+groupRead :: FilePath -> IO ()
+groupRead f = modifyFileMode f $ \cur -> combineModes
+	[ cur
+	, ownerReadMode, groupReadMode
+	]
+
+{- Allows all to read a file. -}
+allRead :: FilePath -> IO ()
+allRead f = modifyFileMode f $ \cur -> combineModes
+	[ cur
+	, ownerReadMode, groupReadMode, otherReadMode
+	]
+
 {- Checks if a file mode indicates it's a symlink. -}
 isSymLink :: FileMode -> Bool
 isSymLink mode = symbolicLinkMode `intersectFileModes` mode == symbolicLinkMode
 
 {- Checks if a file has any executable bits set. -}
 isExecutable :: FileMode -> Bool
-isExecutable mode = ebits `intersectFileModes` mode /= 0
+isExecutable mode = combineModes ebits `intersectFileModes` mode /= 0
 	where
-		ebits = ownerExecuteMode `unionFileModes`
-			groupExecuteMode `unionFileModes` otherExecuteMode
+		ebits = [ownerExecuteMode, groupExecuteMode, otherExecuteMode]

debian/changelog

@@ -2,6 +2,7 @@ git-annex (3.20120419) UNRELEASED; urgency=low
 
   * Fix use of annex.diskreserve config setting.
   * Directory special remotes now check annex.diskreserve.
+  * Support git's core.sharedRepository configuration.
 
  -- Joey Hess <joeyh@debian.org>  Fri, 20 Apr 2012 16:14:08 -0400