honor core.sharedRepository when making all the other files in the annex

Lock files, directories, etc.

8 files changed, 119 insertions, 33 deletions

diff --git a/Annex/Branch.hs b/Annex/Branch.hs
index 52089ac97..e5976c2c0 100644
--- a/Annex/Branch.hs
+++ b/Annex/Branch.hs
@@ -36,6 +36,7 @@ import qualified Git.UnionMerge
 import Git.HashObject
 import qualified Git.Index
 import Annex.CatFile
+import Annex.Perms
 
 {- Name of the branch that is used to store git-annex's information. -}
 name :: Git.Ref
@@ -308,6 +309,7 @@ setIndexSha :: Git.Ref -> Annex ()
 setIndexSha ref = do
         lock <- fromRepo gitAnnexIndexLock
 	liftIO $ writeFile lock $ show ref ++ "\n"
+	setAnnexPerm lock
 
 {- Checks if there are uncommitted changes in the branch's index or journal. -}
 unCommitted :: Annex Bool
diff --git a/Annex/Content.hs b/Annex/Content.hs
index b216b861d..7022364d0 100644
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@@ -46,6 +46,7 @@ import Utility.CopyFile
 import Config
 import Annex.Exception
 import Git.SharedRepository
+import Annex.Perms
 
 {- Checks if a given key's content is currently present. -}
 inAnnex :: Key -> Annex Bool
@@ -141,7 +142,7 @@ getViaTmp key action = do
 prepTmp :: Key -> Annex FilePath
 prepTmp key = do
 	tmp <- fromRepo $ gitAnnexTmpLocation key
-	liftIO $ createDirectoryIfMissing True (parentDir tmp)
+	createAnnexDirectory (parentDir tmp)
 	return tmp
 
 {- Like getViaTmp, but does not check that there is enough disk space
@@ -216,14 +217,11 @@ checkDiskSpace destination key alreadythere = do
 moveAnnex :: Key -> FilePath -> Annex ()
 moveAnnex key src = do
 	dest <- inRepo $ gitAnnexLocation key
-	let dir = parentDir dest
 	ifM (liftIO $ doesFileExist dest)
 		( liftIO $ removeFile src
 		, do
-			liftIO $ do
-				createDirectoryIfMissing True dir
-				allowWrite dir -- in case the directory already exists
-				moveFile src dest
+			createContentDir dest
+			liftIO $ moveFile src dest
 			freezeContent dest
 			freezeContentDir dest
 		)
@@ -268,8 +266,8 @@ moveBad key = do
 	src <- inRepo $ gitAnnexLocation key
 	bad <- fromRepo gitAnnexBadDir
 	let dest = bad </> takeFileName src
+	createAnnexDirectory (parentDir dest)
 	liftIO $ do
-		createDirectoryIfMissing True (parentDir dest)
 		allowWrite (parentDir src)
 		moveFile src dest
 	cleanObjectLoc key
@@ -367,3 +365,13 @@ freezeContentDir file = liftIO . go =<< fromRepo getSharedRepository
 		go AllShared = groupWriteRead dir
 		go _ = preventWrite dir
 
+{- Makes the directory tree to store an annexed file's content,
+ - with appropriate permissions on each level. -}
+createContentDir :: FilePath -> Annex ()
+createContentDir dest = do
+	unlessM (liftIO $ doesDirectoryExist dir) $
+		createAnnexDirectory dir 
+	-- might have already existed with restricted perms
+	liftIO $ allowWrite dir
+	where
+		dir = parentDir dest
diff --git a/Annex/Journal.hs b/Annex/Journal.hs
index 34c4d98c8..ff103180e 100644
--- a/Annex/Journal.hs
+++ b/Annex/Journal.hs
@@ -16,6 +16,7 @@ import System.IO.Binary
 import Common.Annex
 import Annex.Exception
 import qualified Git
+import Annex.Perms
 
 {- Records content for a file in the branch to the journal.
  -
@@ -23,22 +24,20 @@ import qualified Git
  - avoids git needing to rewrite the index after every change. -}
 setJournalFile :: FilePath -> String -> Annex ()
 setJournalFile file content = do
-	g <- gitRepo
-	liftIO $ doRedo (write g) $ do
-		createDirectoryIfMissing True $ gitAnnexJournalDir g
-		createDirectoryIfMissing True $ gitAnnexTmpDir g
-	where
-		-- journal file is written atomically
-		write g = do
-			let jfile = journalFile g file
-			let tmpfile = gitAnnexTmpDir g </> takeFileName jfile
-			writeBinaryFile tmpfile content
-			moveFile tmpfile jfile
+	createAnnexDirectory =<< fromRepo gitAnnexJournalDir
+	createAnnexDirectory =<< fromRepo gitAnnexTmpDir
+	-- journal file is written atomically
+	jfile <- fromRepo $ journalFile file
+	tmp <- fromRepo gitAnnexTmpDir
+	let tmpfile = tmp </> takeFileName jfile
+	liftIO $ do
+		writeBinaryFile tmpfile content
+		moveFile tmpfile jfile
 
 {- Gets any journalled content for a file in the branch. -}
 getJournalFile :: FilePath -> Annex (Maybe String)
 getJournalFile file = inRepo $ \g -> catchMaybeIO $
-	readFileStrict $ journalFile g file
+	readFileStrict $ journalFile file g
 
 {- List of files that have updated content in the journal. -}
 getJournalledFiles :: Annex [FilePath]
@@ -62,8 +61,8 @@ journalDirty = not . null <$> getJournalFiles
  - used in the branch is not necessary, and all the files are put directly
  - in the journal directory.
  -}
-journalFile :: Git.Repo -> FilePath -> FilePath
-journalFile repo file = gitAnnexJournalDir repo </> concatMap mangle file
+journalFile :: FilePath -> Git.Repo -> FilePath
+journalFile file repo = gitAnnexJournalDir repo </> concatMap mangle file
 	where
 		mangle '/' = "_"
 		mangle '_' = "__"
@@ -79,16 +78,12 @@ fileJournal = replace "//" "_" . replace "_" "/"
 lockJournal :: Annex a -> Annex a
 lockJournal a = do
 	file <- fromRepo gitAnnexJournalLock
-	bracketIO (lock file) unlock a
+	createAnnexDirectory $ takeDirectory file
+	mode <- annexFileMode
+	bracketIO (lock file mode) unlock a
 	where
-		lock file = do
-			l <- doRedo (createFile file stdFileMode) $
-				createDirectoryIfMissing True $ takeDirectory file
+		lock file mode = do
+			l <- noUmask mode $ createFile file mode
 			waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0)
 			return l
 		unlock = closeFd
-
-{- Runs an action, catching failure and running something to fix it up, and
- - retrying if necessary. -}
-doRedo :: IO a -> IO b -> IO a
-doRedo a b = catchIO a $ const $ b >> a
diff --git a/Annex/LockPool.hs b/Annex/LockPool.hs
index 3fede5739..3eb1363ee 100644
--- a/Annex/LockPool.hs
+++ b/Annex/LockPool.hs
@@ -12,6 +12,7 @@ import System.Posix.Types (Fd)
 
 import Common.Annex
 import Annex
+import Annex.Perms
 
 {- Create a specified lock file, and takes a shared lock. -}
 lockFile :: FilePath -> Annex ()
@@ -19,7 +20,9 @@ lockFile file = go =<< fromPool file
 	where
 		go (Just _) = return () -- already locked
 		go Nothing = do
-			fd <- liftIO $ openFd file ReadOnly (Just stdFileMode) defaultFileFlags
+			mode <- annexFileMode
+			fd <- liftIO $ noUmask mode $
+				openFd file ReadOnly (Just mode) defaultFileFlags
 			liftIO $ waitToSetLock fd (ReadLock, AbsoluteSeek, 0, 0)
 			changePool $ M.insert file fd
 
diff --git a/Annex/Perms.hs b/Annex/Perms.hs
new file mode 100644
index 000000000..2b54077ca
--- /dev/null
+++ b/Annex/Perms.hs
@@ -0,0 +1,61 @@
+{- git-annex file permissions
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Perms (
+	setAnnexPerm,
+	annexFileMode,
+	createAnnexDirectory,
+	noUmask,
+) where
+
+import Common.Annex
+import Utility.FileMode
+import Git.SharedRepository
+
+import System.Posix.Types
+
+{- Sets appropriate file mode for a file or directory in the annex,
+ - other than the content files and content directory. Normally,
+ - use the default mode, but with core.sharedRepository set,
+ - allow the group to write, etc. -}
+setAnnexPerm :: FilePath -> Annex ()
+setAnnexPerm file = liftIO . go =<< fromRepo getSharedRepository
+	where
+		go GroupShared = groupWriteRead file
+		go AllShared = modifyFileMode file $ addModes $
+			[ ownerWriteMode, groupWriteMode ] ++ readModes
+		go _ = return ()
+
+{- Gets the appropriate mode to use for creating a file in the annex
+ - (other than content files, which are locked down more). -}
+annexFileMode :: Annex FileMode
+annexFileMode = go <$> fromRepo getSharedRepository
+	where
+		go GroupShared = sharedmode
+		go AllShared = combineModes (sharedmode:readModes)
+		go _ = stdFileMode
+		sharedmode = combineModes
+			[ ownerWriteMode, groupWriteMode
+			, ownerReadMode, groupReadMode
+			]
+
+{- Creates a directory inside the gitAnnexDir, including any parent
+ - directories. Makes directories with appropriate permissions. -}
+createAnnexDirectory :: FilePath -> Annex ()
+createAnnexDirectory dir = traverse dir [] =<< top
+	where
+		top = parentDir <$> fromRepo gitAnnexDir
+		traverse d below stop
+			| d `equalFilePath` stop = done
+			| otherwise = ifM (liftIO $ doesDirectoryExist d)
+				( done
+				, traverse (parentDir d) (d:below) stop
+				)
+			where
+				done = forM_ below $ \p -> do
+					liftIO $ createDirectory p
+					setAnnexPerm p
diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs
index e6cd6a926..c9e6e2951 100644
--- a/Annex/Ssh.hs
+++ b/Annex/Ssh.hs
@@ -17,6 +17,7 @@ import Annex.LockPool
 import qualified Git
 import Config
 import qualified Build.SysConfig as SysConfig
+import Annex.Perms
 
 {- Generates parameters to ssh to a given host (or user@host) on a given
  - port, with connection caching. -}
@@ -74,7 +75,9 @@ sshCleanup = do
 			-- be stopped.
 			let lockfile = socket2lock socketfile
 			unlockFile lockfile
-			fd <- liftIO $ openFd lockfile ReadWrite (Just stdFileMode) defaultFileFlags
+			mode <- annexFileMode
+			fd <- liftIO $ noUmask mode $
+				openFd lockfile ReadWrite (Just mode) defaultFileFlags
 			v <- liftIO $ tryIO $
 				setLock fd (WriteLock, AbsoluteSeek, 0, 0)
 			case v of
diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs
index 2864a8ed5..de731bd6e 100644
--- a/Remote/Helper/Hooks.hs
+++ b/Remote/Helper/Hooks.hs
@@ -14,6 +14,7 @@ import Types.Remote
 import qualified Annex
 import Annex.LockPool
 import Config
+import Annex.Perms
 
 {- Modifies a remote's access functions to first run the
  - annex-start-command hook, and trigger annex-stop-command on shutdown.
@@ -75,7 +76,9 @@ runHooks r starthook stophook a = do
 			-- succeeds, we're the only process using this remote,
 			-- so can stop it.
 			unlockFile lck
-			fd <- liftIO $ openFd lck ReadWrite (Just stdFileMode) defaultFileFlags
+			mode <- annexFileMode
+			fd <- liftIO $ noUmask mode $
+				openFd lck ReadWrite (Just mode) defaultFileFlags
 			v <- liftIO $ tryIO $
 				setLock fd (WriteLock, AbsoluteSeek, 0, 0)
 			case v of
diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs
index f3db70923..c0f2ad589 100644
--- a/Utility/FileMode.hs
+++ b/Utility/FileMode.hs
@@ -75,6 +75,17 @@ isExecutable mode = combineModes ebits `intersectFileModes` mode /= 0
 	where
 		ebits = [ownerExecuteMode, groupExecuteMode, otherExecuteMode]
 
+{- Runs an action without that pesky umask influencing it, unless the
+ - passed FileMode is the standard one. -}
+noUmask :: FileMode -> IO a -> IO a
+noUmask mode a
+	| mode == stdFileMode = a
+	| otherwise = bracket setup cleanup go
+	where
+		setup = setFileCreationMask nullFileMode
+		cleanup = setFileCreationMask
+		go _ = a
+
 combineModes :: [FileMode] -> FileMode
 combineModes [] = undefined
 combineModes [m] = m