From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 5 Mar 2020 18:27:45 +0000 (-0400)
Subject: convert createAnnexDirectory to use createDirectoryUnder
X-Git-Tag: archive/raspbian/10.20250416-2+rpi1~2^2^2~104^2~37
X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=ebbc5004faf74e3fd2cb251e7a7fd2a0223ff84a;p=git-annex.git

convert createAnnexDirectory to use createDirectoryUnder

It will create foo/.git/annex/, but not foo/.git/ and not foo/.

This will avoid it creating an empty path to a repo when a drive is
yanked out and the mount point goes away, for example.
---

diff --git a/Annex/Perms.hs b/Annex/Perms.hs
index a24e0362f0..d255ce97ee 100644
--- a/Annex/Perms.hs
+++ b/Annex/Perms.hs
@@ -1,6 +1,6 @@
 {- git-annex file permissions
  -
- - Copyright 2012 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -65,22 +65,17 @@ annexFileMode = withShared $ return . go
 	go _ = stdFileMode
 	sharedmode = combineModes groupSharedModes
 
-{- Creates a directory inside the gitAnnexDir, including any parent
- - directories. Makes directories with appropriate permissions. -}
+{- Creates a directory inside the gitAnnexDir, creating any parent
+ - directories up to and including the gitAnnexDir.
+ - Makes directories with appropriate permissions. -}
 createAnnexDirectory :: FilePath -> Annex ()
-createAnnexDirectory dir = walk dir [] =<< top
+createAnnexDirectory dir = do
+	top <- parentDir . fromRawFilePath <$> fromRepo gitAnnexDir
+	createDirectoryUnder' top dir createdir
   where
-	top = parentDir . fromRawFilePath <$> fromRepo gitAnnexDir
-	walk d below stop
-		| d `equalFilePath` stop = done
-		| otherwise = ifM (liftIO $ doesDirectoryExist d)
-			( done
-			, walk (parentDir d) (d:below) stop
-			)
-	  where
-		done = forM_ below $ \p -> do
-			liftIO $ createDirectoryIfMissing True p
-			setAnnexDirPerm p
+	createdir p = do
+		liftIO $ createDirectory p
+		setAnnexDirPerm p
 
 {- Normally, blocks writing to an annexed file, and modifies file
  - permissions to allow reading it.
diff --git a/Utility/Directory.hs b/Utility/Directory.hs
index d771347546..3cfe632af1 100644
--- a/Utility/Directory.hs
+++ b/Utility/Directory.hs
@@ -19,6 +19,7 @@ import Control.Monad
 import System.FilePath
 import System.PosixCompat.Files
 import Control.Applicative
+import Control.Monad.IO.Class
 import System.IO.Unsafe (unsafeInterleaveIO)
 import System.IO.Error
 import Data.Maybe
@@ -181,20 +182,29 @@ nukeFile file = void $ tryWhenExists go
  - working directory, not to the first FilePath.
  -}
 createDirectoryUnder :: FilePath -> FilePath -> IO ()
-createDirectoryUnder topdir dir0 = do
-	p <- relPathDirToFile topdir dir0
+createDirectoryUnder topdir dir =
+	createDirectoryUnder' topdir dir createDirectory
+
+createDirectoryUnder'
+	:: (MonadIO m, MonadCatch m)
+	=> FilePath
+	-> FilePath
+	-> (FilePath -> m ())
+	-> m ()
+createDirectoryUnder' topdir dir0 mkdir = do
+	p <- liftIO $ relPathDirToFile topdir dir0
 	let dirs = splitDirectories p
 	-- Catch cases where the dir is not beneath the 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 ".." || isAbsolute p
-		then ioError $ customerror userErrorType
+		then liftIO $ ioError $ customerror userErrorType
 			("createDirectoryFrom: not located in " ++ 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 unlessM (doesDirectoryExist topdir) $
+			then liftIO $ unlessM (doesDirectoryExist topdir) $
 				ioError $ customerror doesNotExistErrorType
 					"createDirectoryFrom: does not exist"
 			else createdirs $
@@ -203,20 +213,20 @@ createDirectoryUnder topdir dir0 = do
 	customerror t s = mkIOError t s Nothing (Just dir0)
 
 	createdirs [] = pure ()
-	createdirs (dir:[]) = createdir dir ioError
+	createdirs (dir:[]) = createdir dir (liftIO . ioError)
 	createdirs (dir:dirs) = createdir dir $ \_ -> do
 		createdirs dirs
-		createdir dir ioError
+		createdir dir (liftIO . ioError)
 
 	-- This is the same method used by createDirectoryIfMissing,
 	-- in particular the handling of errors that occur when the
 	-- directory already exists. See its source for explanation
 	-- of several subtleties.
-	createdir dir notexisthandler = tryIOError (createDirectory dir) >>= \case
+	createdir dir notexisthandler = tryIO (mkdir dir) >>= \case
 		Right () -> pure ()
 		Left e
 			| isDoesNotExistError e -> notexisthandler e
-			| isAlreadyExistsError e || isPermissionError e -> do
-				unlessM (doesDirectoryExist dir) $
+			| isAlreadyExistsError e || isPermissionError e ->
+				liftIO $ unlessM (doesDirectoryExist dir) $
 					ioError e
-			| otherwise -> ioError e
+			| otherwise -> liftIO $ ioError e