implemented createDirectoryUnder

diff --git a/Utility/Directory.hs b/Utility/Directory.hs
index e2c6a9462907db0725066a34f9f0239832529edf..d7713475465d50baaf1011f50d5edd24e5ab6ac5 100644 (file)
--- 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 (
@@ -19,6 +20,7 @@ import System.FilePath
 import System.PosixCompat.Files
 import Control.Applicative
 import System.IO.Unsafe (unsafeInterleaveIO)
+import System.IO.Error
 import Data.Maybe
 import Prelude
 
@@ -28,10 +30,12 @@ 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,65 @@ 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 dir0 = do
+       p <- 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
+                       ("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) $
+                               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 ioError
+       createdirs (dir:dirs) = createdir dir $ \_ -> do
+               createdirs dirs
+               createdir dir 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
+               Right () -> pure ()
+               Left e
+                       | isDoesNotExistError e -> notexisthandler e
+                       | isAlreadyExistsError e || isPermissionError e -> do
+                               unlessM (doesDirectoryExist dir) $
+                                       ioError e
+                       | otherwise -> ioError e

diff --git a/doc/todo/stop_using_createDirectoryIfMissing_True/comment_1_09ea803b8f725071add33d03b8e3afa3._comment b/doc/todo/stop_using_createDirectoryIfMissing_True/comment_1_09ea803b8f725071add33d03b8e3afa3._comment
new file mode 100644 (file)
index 0000000..2887656
--- /dev/null
+++ b/doc/todo/stop_using_createDirectoryIfMissing_True/comment_1_09ea803b8f725071add33d03b8e3afa3._comment
@@ -0,0 +1,13 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 1"""
+ date="2020-03-05T17:54:38Z"
+ content="""
+Implemented createDirectoryUnder, now just have to change every
+createDirectoryIfMissing True to it.. There are only 75 of them so not
+super bad?
+
+Also, of course, some library might use it, but I doubt any that do
+create directories inside the git repo, more likely they would be creating
+tmp dirs or stuff like that.
+"""]]