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.
This commit is contained in:
Joey Hess 2020-03-05 14:27:45 -04:00
parent 5b022eea87
commit ebbc5004fa
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
2 changed files with 30 additions and 25 deletions

View file

@ -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