improve createDirectoryUnder to allow alternate top directories

This should not change the behavior of it, unless there are multiple top
directories, and then it should behave the same as if there was a single
top directory that was actually above the directory to be created.

Sponsored-by: Dartmouth College's Datalad project

Annex/AdjustedBranch/Merge.hs

@@ -87,7 +87,7 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm
 					whenM (doesFileExist src) $ do
 						dest <- relPathDirToFile git_dir src'
 						let dest' = toRawFilePath tmpgit P.</> dest
-						createDirectoryUnder git_dir
+						createDirectoryUnder [git_dir]
 							(P.takeDirectory dest')
 						void $ createLinkOrCopy src' dest'
 				-- This reset makes git merge not care
@@ -115,7 +115,7 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm
 		setup = do
 			whenM (doesDirectoryExist d) $
 				removeDirectoryRecursive d
-			createDirectoryUnder git_dir (toRawFilePath d)
+			createDirectoryUnder [git_dir] (toRawFilePath d)
 		cleanup _ = removeDirectoryRecursive d
 
 	{- A merge commit has been made between the basisbranch and 

Annex/ChangedRefs.hs

@@ -83,7 +83,7 @@ watchChangedRefs = do
 	g <- gitRepo
 	let gittop = Git.localGitDir g
 	let refdir = gittop P.</> "refs"
-	liftIO $ createDirectoryUnder gittop refdir
+	liftIO $ createDirectoryUnder [gittop] refdir
 
 	let notifyhook = Just $ notifyHook chan
 	let hooks = mkWatchHooks

Annex/Perms.hs

@@ -112,7 +112,7 @@ annexFileMode = withShared $ return . go
 createAnnexDirectory :: RawFilePath -> Annex ()
 createAnnexDirectory dir = do
 	top <- parentDir <$> fromRepo gitAnnexDir
-	createDirectoryUnder' top dir createdir
+	createDirectoryUnder' [top] dir createdir
   where
 	createdir p = do
 		liftIO $ R.createDirectory p
@@ -126,7 +126,7 @@ createAnnexDirectory dir = do
 createWorkTreeDirectory :: RawFilePath -> Annex ()
 createWorkTreeDirectory dir = do
 	fromRepo repoWorkTree >>= liftIO . \case
-		Just wt -> createDirectoryUnder wt dir
+		Just wt -> createDirectoryUnder [wt] dir
 		-- Should never happen, but let whatever tries to write
 		-- to the directory be what throws an exception, as that
 		-- will be clearer than an exception from here.

Annex/ReplaceFile.hs

@@ -33,7 +33,7 @@ replaceGitAnnexDirFile = replaceFile createAnnexDirectory
 replaceGitDirFile :: FilePath -> (FilePath -> Annex a) -> Annex a
 replaceGitDirFile = replaceFile $ \dir -> do
 	top <- fromRepo localGitDir
-	liftIO $ createDirectoryUnder top dir
+	liftIO $ createDirectoryUnder [top] dir
 
 {- replaceFile on a worktree file. -}
 replaceWorkTreeFile :: FilePath -> (FilePath -> Annex a) -> Annex a

Assistant/Threads/Merger.hs

@@ -34,7 +34,7 @@ mergeThread = namedThread "Merger" $ do
 	g <- liftAnnex gitRepo
 	let gitd = Git.localGitDir g
 	let dir = gitd P.</> "refs"
-	liftIO $ createDirectoryUnder gitd dir
+	liftIO $ createDirectoryUnder [gitd] dir
 	let hook a = Just <$> asIO2 (runHandler a)
 	changehook <- hook onChange
 	errhook <- hook onErr

Config/Smudge.hs

@@ -41,7 +41,7 @@ configureSmudgeFilter = unlessM (fromRepo Git.repoIsLocalBare) $ do
 	gfs <- readattr gf
 	gittop <- Git.localGitDir <$> gitRepo
 	liftIO $ unless ("filter=annex" `isInfixOf` (lfs ++ gfs)) $ do
-		createDirectoryUnder gittop (P.takeDirectory lf)
+		createDirectoryUnder [gittop] (P.takeDirectory lf)
 		writeFile (fromRawFilePath lf) (lfs ++ "\n" ++ unlines stdattr)
   where
 	readattr = liftIO . catchDefaultIO "" . readFileStrict . fromRawFilePath

Database/Init.hs

@@ -40,7 +40,7 @@ initDb db migration = do
 		Just topdbdir -> pure $ parentDir $ topdbdir
 		Nothing -> parentDir <$> fromRepo gitAnnexDir
 	liftIO $ do
-		createDirectoryUnder top tmpdbdir
+		createDirectoryUnder [top] tmpdbdir
 		runSqliteInfo (enableWAL tdb) migration
 	setAnnexDirPerm tmpdbdir
 	-- Work around sqlite bug that prevents it from honoring

Git/Repair.hs

@@ -269,7 +269,7 @@ explodePackedRefsFile r = do
 		let gitd = localGitDir r
 		let dest = gitd P.</> fromRef' ref
 		let dest' = fromRawFilePath dest
-		createDirectoryUnder gitd (parentDir dest)
+		createDirectoryUnder [gitd] (parentDir dest)
 		unlessM (doesFileExist dest') $
 			writeFile dest' (fromRef sha)
 

Remote/Directory.hs

@@ -182,7 +182,7 @@ storeKeyM :: RawFilePath -> ChunkConfig -> CopyCoWTried -> Storer
 storeKeyM d chunkconfig cow k c m = 
 	ifM (checkDiskSpaceDirectory d k)
 		( do
-			void $ liftIO $ tryIO $ createDirectoryUnder d tmpdir
+			void $ liftIO $ tryIO $ createDirectoryUnder [d] tmpdir
 			store
 		, giveup "Not enough free disk space."
 		)
@@ -229,7 +229,7 @@ checkDiskSpaceDirectory d k = do
 finalizeStoreGeneric :: RawFilePath -> RawFilePath -> RawFilePath -> IO ()
 finalizeStoreGeneric d tmp dest = do
 	removeDirGeneric (fromRawFilePath d) dest'
-	createDirectoryUnder d (parentDir dest)
+	createDirectoryUnder [d] (parentDir dest)
 	renameDirectory (fromRawFilePath tmp) dest'
 	-- may fail on some filesystems
 	void $ tryIO $ do
@@ -309,7 +309,7 @@ checkPresentGeneric' d check = ifM check
 
 storeExportM :: RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
 storeExportM d cow src _k loc p = do
-	liftIO $ createDirectoryUnder d (P.takeDirectory dest)
+	liftIO $ createDirectoryUnder [d] (P.takeDirectory dest)
 	-- Write via temp file so that checkPresentGeneric will not
 	-- see it until it's fully stored.
 	viaTmp go (fromRawFilePath dest) ()
@@ -337,7 +337,7 @@ checkPresentExportM d _k loc =
 
 renameExportM :: RawFilePath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ())
 renameExportM d _k oldloc newloc = liftIO $ do
-	createDirectoryUnder d (P.takeDirectory dest)
+	createDirectoryUnder [d] (P.takeDirectory dest)
 	renameFile (fromRawFilePath src) (fromRawFilePath dest)
 	removeExportLocation d oldloc
 	return (Just ())
@@ -502,7 +502,7 @@ retrieveExportWithContentIdentifierM ii dir cow loc cid dest gk p =
 
 storeExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier
 storeExportWithContentIdentifierM ii dir cow src _k loc overwritablecids p = do
-	liftIO $ createDirectoryUnder dir (toRawFilePath destdir)
+	liftIO $ createDirectoryUnder [dir] (toRawFilePath destdir)
 	withTmpFileIn destdir template $ \tmpf tmph -> do
 		liftIO $ hClose tmph
 		void $ liftIO $ fileCopier cow src tmpf p Nothing

Remote/Directory/LegacyChunked.hs

@@ -79,7 +79,7 @@ storeLegacyChunked' meterupdate chunksize (d:dests) bs c = do
 storeHelper :: FilePath -> (RawFilePath -> RawFilePath -> IO ()) -> Key -> ([FilePath] -> IO [FilePath]) -> FilePath -> FilePath -> IO ()
 storeHelper repotop finalizer key storer tmpdir destdir = do
 	void $ liftIO $ tryIO $ createDirectoryUnder
-		(toRawFilePath repotop)
+		[toRawFilePath repotop]
 		(toRawFilePath tmpdir)
 	Legacy.storeChunks key tmpdir destdir storer recorder (legacyFinalizer finalizer)
   where

Remote/GCrypt.hs

@@ -388,7 +388,7 @@ store' repo r rsyncopts accessmethod
 	| not $ Git.repoIsUrl repo = 
 		byteStorer $ \k b p -> guardUsable repo (giveup "cannot access remote") $ liftIO $ do
 			let tmpdir = Git.repoPath repo P.</> "tmp" P.</> keyFile k
-			void $ tryIO $ createDirectoryUnder (Git.repoPath repo) tmpdir
+			void $ tryIO $ createDirectoryUnder [Git.repoPath repo] tmpdir
 			let tmpf = tmpdir P.</> keyFile k
 			meteredWriteFile p (fromRawFilePath tmpf) b
 			let destdir = parentDir $ toRawFilePath $ gCryptLocation repo k

Utility/Directory/Create.hs

@@ -31,10 +31,10 @@ import qualified Utility.RawFilePath as R
 import Utility.PartialPrelude
 
 {- Like createDirectoryIfMissing True, but it will only create
- - missing parent directories up to but not including the directory
- - in the first parameter.
+ - missing parent directories up to but not including a directory
+ - from the first parameter.
  -
- - For example, createDirectoryUnder "/tmp/foo" "/tmp/foo/bar/baz"
+ - For example, createDirectoryUnder ["/tmp/foo"] "/tmp/foo/bar/baz"
  - will create /tmp/foo/bar if necessary, but if /tmp/foo does not exist,
  - it will throw an exception.
  -
@@ -45,40 +45,43 @@ import Utility.PartialPrelude
  - FilePath (or the same as it), it will fail with an exception
  - even if the second FilePath's parent directory already exists.
  -
- - Either or both of the FilePaths can be relative, or absolute.
+ - The FilePaths can be relative, or absolute. 
  - They will be normalized as necessary.
  -
  - Note that, the second FilePath, if relative, is relative to the current
- - working directory, not to the first FilePath.
+ - working directory.
  -}
-createDirectoryUnder :: RawFilePath -> RawFilePath -> IO ()
-createDirectoryUnder topdir dir =
-	createDirectoryUnder' topdir dir R.createDirectory
+createDirectoryUnder :: [RawFilePath] -> RawFilePath -> IO ()
+createDirectoryUnder topdirs dir =
+	createDirectoryUnder' topdirs dir R.createDirectory
 
 createDirectoryUnder'
 	:: (MonadIO m, MonadCatch m)
-	=> RawFilePath
+	=> [RawFilePath]
 	-> RawFilePath
 	-> (RawFilePath -> m ())
 	-> m ()
-createDirectoryUnder' topdir dir0 mkdir = do
-	p <- liftIO $ relPathDirToFile topdir dir0
-	let dirs = P.splitDirectories p
-	-- Catch cases where the dir is not beneath the topdir.
+createDirectoryUnder' topdirs dir0 mkdir = do
+	relps <- liftIO $ forM topdirs $ \topdir -> relPathDirToFile topdir dir0
+	let relparts = map P.splitDirectories relps
+	-- Catch cases where dir0 is not beneath a topdir.
 	-- If the relative path between them starts with "..",
 	-- it's not. And on Windows, if they are on different drives,
 	-- the path will not be relative.
-	if headMaybe dirs == Just ".." || P.isAbsolute p
-		then liftIO $ ioError $ customerror userErrorType
-			("createDirectoryFrom: not located in " ++ fromRawFilePath topdir)
-		-- If dir0 is the same as the topdir, don't try to create
-		-- it, but make sure it does exist.
-		else if null dirs
-			then liftIO $ unlessM (doesDirectoryExist (fromRawFilePath topdir)) $
-				ioError $ customerror doesNotExistErrorType
-					"createDirectoryFrom: does not exist"
-			else createdirs $
-				map (topdir P.</>) (reverse (scanl1 (P.</>) dirs))
+	let notbeneath = \(_topdir, (relp, dirs)) -> 
+		headMaybe dirs /= Just ".." && not (P.isAbsolute relp)
+	case filter notbeneath $ zip topdirs (zip relps relparts) of
+		((topdir, (_relp, dirs)):_)
+			-- If dir0 is the same as the topdir, don't try to
+			-- create it, but make sure it does exist.
+			| null dirs ->
+				liftIO $ unlessM (doesDirectoryExist (fromRawFilePath topdir)) $
+					ioError $ customerror doesNotExistErrorType $
+						"createDirectoryFrom: " ++ fromRawFilePath topdir ++ " does not exist"
+			| otherwise -> createdirs $
+					map (topdir P.</>) (reverse (scanl1 (P.</>) dirs))
+		_ -> liftIO $ ioError $ customerror userErrorType
+			("createDirectoryFrom: not located in " ++ unwords (map fromRawFilePath topdirs))
   where
 	customerror t s = mkIOError t s Nothing (Just (fromRawFilePath dir0))