convert replaceFile to createDirectoryUnder

Since it was used on both worktree and .git/annex files, split into
multiple functions.

In passing, this also improves permissions of created directories in
.git/annex, using createAnnexDirectory on those.

Annex/AutoMerge.hs

@@ -208,7 +208,7 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
 		stageSymlink dest' =<< hashSymlink l
 
 	replacewithsymlink dest link = withworktree dest $ \f ->
-		replaceFile f $ makeGitLink link . toRawFilePath
+		replaceWorkTreeFile f $ makeGitLink link . toRawFilePath
 
 	makepointer key dest destmode = do
 		unless inoverlay $ 
@@ -256,7 +256,7 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
 				, case selectwant' (LsFiles.unmergedSha u) of
 					Nothing -> noop
 					Just sha -> withworktree item $ \f -> 
-						replaceFile f $ \tmp -> do
+						replaceWorkTreeFile f $ \tmp -> do
 							c <- catObject sha
 							liftIO $ L.writeFile tmp c
 				)

Annex/Content/PointerFile.hs

@@ -39,7 +39,7 @@ populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f)
 		let f' = fromRawFilePath f
 		destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f'
 		liftIO $ nukeFile f'
-		(ic, populated) <- replaceFile f' $ \tmp -> do
+		(ic, populated) <- replaceWorkTreeFile f' $ \tmp -> do
 			let tmp' = toRawFilePath tmp
 			ok <- linkOrCopy k (fromRawFilePath obj) tmp destmode >>= \case
 				Just _ -> thawContent tmp >> return True
@@ -62,7 +62,7 @@ depopulatePointerFile key file = do
 	let mode = fmap fileMode st
 	secureErase file'
 	liftIO $ nukeFile file'
-	ic <- replaceFile file' $ \tmp -> do
+	ic <- replaceWorkTreeFile file' $ \tmp -> do
 		liftIO $ writePointerFile (toRawFilePath tmp) key mode
 #if ! defined(mingw32_HOST_OS)
 		-- Don't advance mtime; this avoids unncessary re-smudging

Annex/Ingest.hs

@@ -274,7 +274,7 @@ restoreFile file key e = do
 makeLink :: FilePath -> Key -> Maybe InodeCache -> Annex String
 makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do
 	l <- calcRepo $ gitAnnexLink file key
-	replaceFile file $ makeAnnexLink l . toRawFilePath
+	replaceWorkTreeFile file $ makeAnnexLink l . toRawFilePath
 
 	-- touch symlink to have same time as the original file,
 	-- as provided in the InodeCache

Annex/ReplaceFile.hs

@@ -1,21 +1,48 @@
 {- git-annex file replacing
  -
- - Copyright 2013-2015 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2020 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
 {-# LANGUAGE CPP #-}
 
-module Annex.ReplaceFile where
+module Annex.ReplaceFile (
+	replaceGitAnnexDirFile,
+	replaceGitDirFile,
+	replaceWorkTreeFile,
+	replaceFile,
+) where
 
 import Annex.Common
 import Annex.Tmp
+import Annex.Perms
+import Git
 import Utility.Tmp.Dir
 #ifndef mingw32_HOST_OS
 import Utility.Path.Max
 #endif
 
+{- replaceFile on a file located inside the gitAnnexDir. -}
+replaceGitAnnexDirFile :: FilePath -> (FilePath -> Annex a) -> Annex a
+replaceGitAnnexDirFile = replaceFile createAnnexDirectory
+
+{- replaceFile on a file located inside the .git directory. -}
+replaceGitDirFile :: FilePath -> (FilePath -> Annex a) -> Annex a
+replaceGitDirFile = replaceFile $ \dir -> do
+	top <- fromRawFilePath <$> fromRepo localGitDir
+	liftIO $ createDirectoryUnder top dir
+
+{- replaceFile on a worktree file. -}
+replaceWorkTreeFile :: FilePath -> (FilePath -> Annex a) -> Annex a
+replaceWorkTreeFile = replaceFile $ \dir ->
+	fromRepo repoWorkTree >>= liftIO . \case
+		Just wt -> createDirectoryUnder (fromRawFilePath wt) dir
+		-- Should never happen, but let the file move be what
+		-- throws an exception as that would more clearly indicate
+		-- the problem.
+		Nothing -> noop
+
 {- Replaces a possibly already existing file with a new version, 
  - atomically, by running an action.
  - 
@@ -27,9 +54,12 @@ import Utility.Path.Max
  - will be deleted, and the existing file will be preserved.
  -
  - Throws an IO exception when it was unable to replace the file.
+ -
+ - The createdirectory action is only run when moving the file into place
+ - fails, and can create any parent directory structure needed.
  -}
-replaceFile :: FilePath -> (FilePath -> Annex a) -> Annex a
-replaceFile file action = withOtherTmp $ \othertmpdir -> do
+replaceFile :: (FilePath -> Annex ()) -> FilePath -> (FilePath -> Annex a) -> Annex a
+replaceFile createdirectory file action = withOtherTmp $ \othertmpdir -> do
 #ifndef mingw32_HOST_OS
 	-- Use part of the filename as the template for the temp
 	-- directory. This does not need to be unique, but it
@@ -44,13 +74,13 @@ replaceFile file action = withOtherTmp $ \othertmpdir -> do
 	withTmpDirIn othertmpdir basetmp $ \tmpdir -> do
 		let tmpfile = tmpdir </> basetmp
 		r <- action tmpfile
-		liftIO $ replaceFileFrom tmpfile file
+		replaceFileFrom tmpfile file createdirectory
 		return r
 
-replaceFileFrom :: FilePath -> FilePath -> IO ()
-replaceFileFrom src dest = go `catchIO` fallback
+replaceFileFrom :: FilePath -> FilePath -> (FilePath -> Annex ()) -> Annex ()
+replaceFileFrom src dest createdirectory = go `catchIO` fallback
   where
-	go = moveFile src dest
+	go = liftIO $ moveFile src dest
 	fallback _ = do
-		createDirectoryIfMissing True $ parentDir dest
+		createdirectory (parentDir dest)
 		go

Annex/WorkTree.hs

@@ -100,7 +100,7 @@ scanUnlockedFiles = whenM (inRepo Git.Ref.headExists <&&> not <$> isBareRepo) $
 				Just k' | k' == k -> do
 					destmode <- liftIO $ catchMaybeIO $
 						fileMode <$> R.getFileStatus f
-					ic <- replaceFile (fromRawFilePath f) $ \tmp -> do
+					ic <- replaceWorkTreeFile (fromRawFilePath f) $ \tmp -> do
 						let tmp' = toRawFilePath tmp
 						linkFromAnnex k tmp destmode >>= \case
 							LinkAnnexOk -> 

Assistant/Threads/Watcher.hs

@@ -300,7 +300,7 @@ onAddSymlink' linktarget mk file filestatus = go mk
 		if linktarget == Just link
 			then ensurestaged (Just link) =<< getDaemonStatus
 			else do
-				liftAnnex $ replaceFile file $
+				liftAnnex $ replaceWorkTreeFile file $
 					makeAnnexLink link . toRawFilePath
 				addLink file link (Just key)
 	-- other symlink, not git-annex

Command/Fix.hs

@@ -67,7 +67,7 @@ start fixwhat file key = do
 
 breakHardLink :: RawFilePath -> Key -> RawFilePath -> CommandPerform
 breakHardLink file key obj = do
-	replaceFile (fromRawFilePath file) $ \tmp -> do
+	replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
 		mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
 		let obj' = fromRawFilePath obj
 		unlessM (checkedCopyFile key obj' tmp mode) $
@@ -79,7 +79,7 @@ breakHardLink file key obj = do
 
 makeHardLink :: RawFilePath -> Key -> CommandPerform
 makeHardLink file key = do
-	replaceFile (fromRawFilePath file) $ \tmp -> do
+	replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
 		mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
 		linkFromAnnex key tmp mode >>= \case
 			LinkAnnexFailed -> error "unable to make hard link"

Command/Fsck.hs

@@ -332,7 +332,7 @@ verifyWorkTree key file = do
 	case mk of
 		Just k | k == key -> whenM (inAnnex key) $ do
 			showNote "fixing worktree content"
-			replaceFile (fromRawFilePath file) $ \tmp -> do
+			replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
 				mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
 				ifM (annexThin <$> Annex.getGitConfig)
 					( void $ linkFromAnnex key tmp mode

Command/Lock.hs

@@ -74,7 +74,7 @@ performNew file key = do
 		mfc <- withTSDelta (liftIO . genInodeCache file)
 		unlessM (sameInodeCache obj (maybeToList mfc)) $ do
 			let obj' = fromRawFilePath obj
-			modifyContent obj' $ replaceFile obj' $ \tmp -> do
+			modifyContent obj' $ replaceGitAnnexDirFile obj' $ \tmp -> do
 				unlessM (checkedCopyFile key obj' tmp Nothing) $
 					giveup "unable to lock file"
 			Database.Keys.storeInodeCaches key [obj]

Command/ReKey.hs

@@ -93,7 +93,7 @@ linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file)
 			st <- liftIO $ R.getFileStatus file
 			when (linkCount st > 1) $ do
 				freezeContent oldobj
-				replaceFile (fromRawFilePath file) $ \tmp -> do
+				replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
 					unlessM (checkedCopyFile oldkey oldobj tmp Nothing) $
 						error "can't lock old key"
 					thawContent tmp

Command/Unlock.hs

@@ -29,9 +29,6 @@ mkcmd n d = withGlobalOptions [jsonOptions, annexedMatchingOptions] $
 seek :: CmdParams -> CommandSeek
 seek ps = withFilesInGit (commandAction . whenAnnexed start) =<< workTreeItems ps
 
-{- Before v6, the unlock subcommand replaces the symlink with a copy of
- - the file's content. In v6 and above, it converts the file from a symlink
- - to a pointer. -}
 start :: RawFilePath -> Key -> CommandStart
 start file key = ifM (isJust <$> isAnnexLink file)
 	( starting "unlock" (mkActionItem (key, AssociatedFile (Just file))) $
@@ -42,7 +39,7 @@ start file key = ifM (isJust <$> isAnnexLink file)
 perform :: RawFilePath -> Key -> CommandPerform
 perform dest key = do
 	destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus dest
-	replaceFile (fromRawFilePath dest) $ \tmp ->
+	replaceWorkTreeFile (fromRawFilePath dest) $ \tmp ->
 		ifM (inAnnex key)
 			( do
 				r <- linkFromAnnex key tmp destmode

Logs/File.hs

@@ -29,7 +29,7 @@ writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog f c
 withLogHandle :: FilePath -> (Handle -> Annex a) -> Annex a
 withLogHandle f a = do
 	createAnnexDirectory (parentDir f)
-	replaceFile f $ \tmp ->
+	replaceGitAnnexDirFile f $ \tmp ->
 		bracket (setup tmp) cleanup a
   where
 	setup tmp = do