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 a24e0362f00bac9e73eebad618d6dfcb38f20cc3..d255ce97ee17e7c2fcba0ecc4457d107ea8e7768 100644 (file)
--- 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 d7713475465d50baaf1011f50d5edd24e5ab6ac5..3cfe632af16a43231eb090ba8f8a87b7eec8b6ef 100644 (file)
--- 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