diff options
author | Joey Hess <joeyh@joeyh.name> | 2020-05-04 15:38:39 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2020-05-04 15:38:39 -0400 |
commit | 8c4352a0a544b2e5a4ed717999fc7c6ecb0a328f (patch) | |
tree | d57aca56117598b06bf30e5a1ed96f4b77e51f09 /Utility/Directory.hs | |
parent | 6ea7eac330f73699d965cef7b8ee23d7218415a8 (diff) | |
download | git-repair-8c4352a0a544b2e5a4ed717999fc7c6ecb0a328f.tar.gz |
merge from git-annex
* Improve fetching from a remote with an url in host:path format.
* Merge from git-annex.
Diffstat (limited to 'Utility/Directory.hs')
-rw-r--r-- | Utility/Directory.hs | 81 |
1 files changed, 78 insertions, 3 deletions
diff --git a/Utility/Directory.hs b/Utility/Directory.hs index e2c6a94..8b5b88b 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -1,11 +1,12 @@ {- directory traversal and manipulation - - - Copyright 2011-2014 Joey Hess <id@joeyh.name> + - Copyright 2011-2020 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Directory ( @@ -13,25 +14,28 @@ module Utility.Directory ( module Utility.SystemDirectory ) where -import System.IO.Error import Control.Monad import System.FilePath import System.PosixCompat.Files import Control.Applicative +import Control.Monad.IO.Class +import Control.Monad.IfElse import System.IO.Unsafe (unsafeInterleaveIO) +import System.IO.Error import Data.Maybe import Prelude #ifndef mingw32_HOST_OS import Utility.SafeCommand -import Control.Monad.IfElse #endif import Utility.SystemDirectory +import Utility.Path import Utility.Tmp import Utility.Exception import Utility.Monad import Utility.Applicative +import Utility.PartialPrelude dirCruft :: FilePath -> Bool dirCruft "." = True @@ -154,3 +158,74 @@ nukeFile file = void $ tryWhenExists go #else go = removeFile file #endif + +{- Like createDirectoryIfMissing True, but it will only create + - missing parent directories up to but not including the directory + - in the first parameter. + - + - 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. + - + - The exception thrown is the same that createDirectory throws if the + - parent directory does not exist. + - + - If the second FilePath is not under the first + - 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. + - 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. + -} +createDirectoryUnder :: FilePath -> FilePath -> IO () +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 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 liftIO $ unlessM (doesDirectoryExist topdir) $ + ioError $ customerror doesNotExistErrorType + "createDirectoryFrom: does not exist" + else createdirs $ + map (topdir </>) (reverse (scanl1 (</>) dirs)) + where + customerror t s = mkIOError t s Nothing (Just dir0) + + createdirs [] = pure () + createdirs (dir:[]) = createdir dir (liftIO . ioError) + createdirs (dir:dirs) = createdir dir $ \_ -> do + createdirs dirs + 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 = tryIO (mkdir dir) >>= \case + Right () -> pure () + Left e + | isDoesNotExistError e -> notexisthandler e + | isAlreadyExistsError e || isPermissionError e -> + liftIO $ unlessM (doesDirectoryExist dir) $ + ioError e + | otherwise -> liftIO $ ioError e |