improve createDirectoryUnder to allow alternate top directories

This should not change the behavior of it, unless there are multiple top
directories, and then it should behave the same as if there was a single
top directory that was actually above the directory to be created.

Sponsored-by: Dartmouth College's Datalad project

diff --git a/Annex/AdjustedBranch/Merge.hs b/Annex/AdjustedBranch/Merge.hs
index 79f86c2884eb0dd76df354e11b9f8bb79652d1ca..d3031cd47834c85fc963082f7f60979cd0b1e01f 100644 (file)
--- a/Annex/AdjustedBranch/Merge.hs
+++ b/Annex/AdjustedBranch/Merge.hs
@@ -87,7 +87,7 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm
                                        whenM (doesFileExist src) $ do
                                                dest <- relPathDirToFile git_dir src'
                                                let dest' = toRawFilePath tmpgit P.</> dest
-                                               createDirectoryUnder git_dir
+                                               createDirectoryUnder [git_dir]
                                                        (P.takeDirectory dest')
                                                void $ createLinkOrCopy src' dest'
                                -- This reset makes git merge not care
@@ -115,7 +115,7 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm
                setup = do
                        whenM (doesDirectoryExist d) $
                                removeDirectoryRecursive d
-                       createDirectoryUnder git_dir (toRawFilePath d)
+                       createDirectoryUnder [git_dir] (toRawFilePath d)
                cleanup _ = removeDirectoryRecursive d
 
        {- A merge commit has been made between the basisbranch and 

diff --git a/Annex/ChangedRefs.hs b/Annex/ChangedRefs.hs
index 4450bd4c4cc74c8304edbed723ce4dc5eaadb9f9..83aa5561a7846fb433ecdcce19f3989e1bded8f1 100644 (file)
--- a/Annex/ChangedRefs.hs
+++ b/Annex/ChangedRefs.hs
@@ -83,7 +83,7 @@ watchChangedRefs = do
        g <- gitRepo
        let gittop = Git.localGitDir g
        let refdir = gittop P.</> "refs"
-       liftIO $ createDirectoryUnder gittop refdir
+       liftIO $ createDirectoryUnder [gittop] refdir
 
        let notifyhook = Just $ notifyHook chan
        let hooks = mkWatchHooks

diff --git a/Annex/Perms.hs b/Annex/Perms.hs
index 63178883dff416ddb54c8938420b0de38a8b563d..73fa6172f13f4007562776a50018aaa809521afd 100644 (file)
--- a/Annex/Perms.hs
+++ b/Annex/Perms.hs
@@ -112,7 +112,7 @@ annexFileMode = withShared $ return . go
 createAnnexDirectory :: RawFilePath -> Annex ()
 createAnnexDirectory dir = do
        top <- parentDir <$> fromRepo gitAnnexDir
-       createDirectoryUnder' top dir createdir
+       createDirectoryUnder' [top] dir createdir
   where
        createdir p = do
                liftIO $ R.createDirectory p
@@ -126,7 +126,7 @@ createAnnexDirectory dir = do
 createWorkTreeDirectory :: RawFilePath -> Annex ()
 createWorkTreeDirectory dir = do
        fromRepo repoWorkTree >>= liftIO . \case
-               Just wt -> createDirectoryUnder wt dir
+               Just wt -> createDirectoryUnder [wt] dir
                -- Should never happen, but let whatever tries to write
                -- to the directory be what throws an exception, as that
                -- will be clearer than an exception from here.

diff --git a/Annex/ReplaceFile.hs b/Annex/ReplaceFile.hs
index 21c6f29744bc1eb7f9e74d661fe561c0b5365351..9f671cb9d6b8c7fde4010eded37209a62c52b7df 100644 (file)
--- a/Annex/ReplaceFile.hs
+++ b/Annex/ReplaceFile.hs
@@ -33,7 +33,7 @@ replaceGitAnnexDirFile = replaceFile createAnnexDirectory
 replaceGitDirFile :: FilePath -> (FilePath -> Annex a) -> Annex a
 replaceGitDirFile = replaceFile $ \dir -> do
        top <- fromRepo localGitDir
-       liftIO $ createDirectoryUnder top dir
+       liftIO $ createDirectoryUnder [top] dir
 
 {- replaceFile on a worktree file. -}
 replaceWorkTreeFile :: FilePath -> (FilePath -> Annex a) -> Annex a

diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs
index 23c9700df0801b18d2736d8d3d3db170f54d9d87..01f7200801fd7ce1c450f9a7c93e55b359aa9fe1 100644 (file)
--- a/Assistant/Threads/Merger.hs
+++ b/Assistant/Threads/Merger.hs
@@ -34,7 +34,7 @@ mergeThread = namedThread "Merger" $ do
        g <- liftAnnex gitRepo
        let gitd = Git.localGitDir g
        let dir = gitd P.</> "refs"
-       liftIO $ createDirectoryUnder gitd dir
+       liftIO $ createDirectoryUnder [gitd] dir
        let hook a = Just <$> asIO2 (runHandler a)
        changehook <- hook onChange
        errhook <- hook onErr

diff --git a/Config/Smudge.hs b/Config/Smudge.hs
index 3a33bcfda30158cc971c6eb0046ae425f0f972b3..2b3303307f442584cb87950f2a845cedfecca84a 100644 (file)
--- a/Config/Smudge.hs
+++ b/Config/Smudge.hs
@@ -41,7 +41,7 @@ configureSmudgeFilter = unlessM (fromRepo Git.repoIsLocalBare) $ do
        gfs <- readattr gf
        gittop <- Git.localGitDir <$> gitRepo
        liftIO $ unless ("filter=annex" `isInfixOf` (lfs ++ gfs)) $ do
-               createDirectoryUnder gittop (P.takeDirectory lf)
+               createDirectoryUnder [gittop] (P.takeDirectory lf)
                writeFile (fromRawFilePath lf) (lfs ++ "\n" ++ unlines stdattr)
   where
        readattr = liftIO . catchDefaultIO "" . readFileStrict . fromRawFilePath

diff --git a/Database/Init.hs b/Database/Init.hs
index 13a8d9574bcb92ae5e30768e3b636d3653b28a8d..2b63a38513f1ecfce681565697fc8c01dece21f9 100644 (file)
--- a/Database/Init.hs
+++ b/Database/Init.hs
@@ -40,7 +40,7 @@ initDb db migration = do
                Just topdbdir -> pure $ parentDir $ topdbdir
                Nothing -> parentDir <$> fromRepo gitAnnexDir
        liftIO $ do
-               createDirectoryUnder top tmpdbdir
+               createDirectoryUnder [top] tmpdbdir
                runSqliteInfo (enableWAL tdb) migration
        setAnnexDirPerm tmpdbdir
        -- Work around sqlite bug that prevents it from honoring

diff --git a/Git/Repair.hs b/Git/Repair.hs
index 7e058e25dfd56e6d3726e5765aafd2ab70f9d38c..3b51ff14791b3374c673fdeb0816618d2ee96042 100644 (file)
--- a/Git/Repair.hs
+++ b/Git/Repair.hs
@@ -269,7 +269,7 @@ explodePackedRefsFile r = do
                let gitd = localGitDir r
                let dest = gitd P.</> fromRef' ref
                let dest' = fromRawFilePath dest
-               createDirectoryUnder gitd (parentDir dest)
+               createDirectoryUnder [gitd] (parentDir dest)
                unlessM (doesFileExist dest') $
                        writeFile dest' (fromRef sha)
 

diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 96490f4a9bbe4f70f5accc95696cf9398acbcac8..8220b57dda44e871799b34fd148d3f4e9f207118 100644 (file)
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -182,7 +182,7 @@ storeKeyM :: RawFilePath -> ChunkConfig -> CopyCoWTried -> Storer
 storeKeyM d chunkconfig cow k c m = 
        ifM (checkDiskSpaceDirectory d k)
                ( do
-                       void $ liftIO $ tryIO $ createDirectoryUnder d tmpdir
+                       void $ liftIO $ tryIO $ createDirectoryUnder [d] tmpdir
                        store
                , giveup "Not enough free disk space."
                )
@@ -229,7 +229,7 @@ checkDiskSpaceDirectory d k = do
 finalizeStoreGeneric :: RawFilePath -> RawFilePath -> RawFilePath -> IO ()
 finalizeStoreGeneric d tmp dest = do
        removeDirGeneric (fromRawFilePath d) dest'
-       createDirectoryUnder d (parentDir dest)
+       createDirectoryUnder [d] (parentDir dest)
        renameDirectory (fromRawFilePath tmp) dest'
        -- may fail on some filesystems
        void $ tryIO $ do
@@ -309,7 +309,7 @@ checkPresentGeneric' d check = ifM check
 
 storeExportM :: RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
 storeExportM d cow src _k loc p = do
-       liftIO $ createDirectoryUnder d (P.takeDirectory dest)
+       liftIO $ createDirectoryUnder [d] (P.takeDirectory dest)
        -- Write via temp file so that checkPresentGeneric will not
        -- see it until it's fully stored.
        viaTmp go (fromRawFilePath dest) ()
@@ -337,7 +337,7 @@ checkPresentExportM d _k loc =
 
 renameExportM :: RawFilePath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ())
 renameExportM d _k oldloc newloc = liftIO $ do
-       createDirectoryUnder d (P.takeDirectory dest)
+       createDirectoryUnder [d] (P.takeDirectory dest)
        renameFile (fromRawFilePath src) (fromRawFilePath dest)
        removeExportLocation d oldloc
        return (Just ())
@@ -502,7 +502,7 @@ retrieveExportWithContentIdentifierM ii dir cow loc cid dest gk p =
 
 storeExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier
 storeExportWithContentIdentifierM ii dir cow src _k loc overwritablecids p = do
-       liftIO $ createDirectoryUnder dir (toRawFilePath destdir)
+       liftIO $ createDirectoryUnder [dir] (toRawFilePath destdir)
        withTmpFileIn destdir template $ \tmpf tmph -> do
                liftIO $ hClose tmph
                void $ liftIO $ fileCopier cow src tmpf p Nothing

diff --git a/Remote/Directory/LegacyChunked.hs b/Remote/Directory/LegacyChunked.hs
index 42a94f8d021c587ceff3508b94704ba95ef41871..fe1065d76cf57ea9b408bee7cc47910b40e0344c 100644 (file)
--- a/Remote/Directory/LegacyChunked.hs
+++ b/Remote/Directory/LegacyChunked.hs
@@ -79,7 +79,7 @@ storeLegacyChunked' meterupdate chunksize (d:dests) bs c = do
 storeHelper :: FilePath -> (RawFilePath -> RawFilePath -> IO ()) -> Key -> ([FilePath] -> IO [FilePath]) -> FilePath -> FilePath -> IO ()
 storeHelper repotop finalizer key storer tmpdir destdir = do
        void $ liftIO $ tryIO $ createDirectoryUnder
-               (toRawFilePath repotop)
+               [toRawFilePath repotop]
                (toRawFilePath tmpdir)
        Legacy.storeChunks key tmpdir destdir storer recorder (legacyFinalizer finalizer)
   where

diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index e78a6c88ed6c16275686097c0e038aaf5371ad0c..f758932bdcc16844041f9cf97aa7a388da9ce0e6 100644 (file)
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -388,7 +388,7 @@ store' repo r rsyncopts accessmethod
        | not $ Git.repoIsUrl repo = 
                byteStorer $ \k b p -> guardUsable repo (giveup "cannot access remote") $ liftIO $ do
                        let tmpdir = Git.repoPath repo P.</> "tmp" P.</> keyFile k
-                       void $ tryIO $ createDirectoryUnder (Git.repoPath repo) tmpdir
+                       void $ tryIO $ createDirectoryUnder [Git.repoPath repo] tmpdir
                        let tmpf = tmpdir P.</> keyFile k
                        meteredWriteFile p (fromRawFilePath tmpf) b
                        let destdir = parentDir $ toRawFilePath $ gCryptLocation repo k

diff --git a/Utility/Directory/Create.hs b/Utility/Directory/Create.hs
index 32c0bcfd468879fe7cedc3d6072394a06bd75d47..5650f96db1047322144355c1b151b1c44affc64c 100644 (file)
--- a/Utility/Directory/Create.hs
+++ b/Utility/Directory/Create.hs
@@ -31,10 +31,10 @@ import qualified Utility.RawFilePath as R
 import Utility.PartialPrelude
 
 {- Like createDirectoryIfMissing True, but it will only create
- - missing parent directories up to but not including the directory
- - in the first parameter.
+ - missing parent directories up to but not including a directory
+ - from the first parameter.
  -
- - For example, createDirectoryUnder "/tmp/foo" "/tmp/foo/bar/baz"
+ - 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.
  -
@@ -45,40 +45,43 @@ import Utility.PartialPrelude
  - 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.
+ - 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.
+ - working directory.
  -}
-createDirectoryUnder :: RawFilePath -> RawFilePath -> IO ()
-createDirectoryUnder topdir dir =
-       createDirectoryUnder' topdir dir R.createDirectory
+createDirectoryUnder :: [RawFilePath] -> RawFilePath -> IO ()
+createDirectoryUnder topdirs dir =
+       createDirectoryUnder' topdirs dir R.createDirectory
 
 createDirectoryUnder'
        :: (MonadIO m, MonadCatch m)
-       => RawFilePath
+       => [RawFilePath]
        -> RawFilePath
        -> (RawFilePath -> m ())
        -> m ()
-createDirectoryUnder' topdir dir0 mkdir = do
-       p <- liftIO $ relPathDirToFile topdir dir0
-       let dirs = P.splitDirectories p
-       -- Catch cases where the dir is not beneath the topdir.
+createDirectoryUnder' topdirs dir0 mkdir = do
+       relps <- liftIO $ forM topdirs $ \topdir -> relPathDirToFile topdir dir0
+       let relparts = map P.splitDirectories relps
+       -- Catch cases where dir0 is not beneath a 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 ".." || P.isAbsolute p
-               then liftIO $ ioError $ customerror userErrorType
-                       ("createDirectoryFrom: not located in " ++ fromRawFilePath 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 (fromRawFilePath topdir)) $
-                               ioError $ customerror doesNotExistErrorType
-                                       "createDirectoryFrom: does not exist"
-                       else createdirs $
-                               map (topdir P.</>) (reverse (scanl1 (P.</>) dirs))
+       let notbeneath = \(_topdir, (relp, dirs)) -> 
+               headMaybe dirs /= Just ".." && not (P.isAbsolute relp)
+       case filter notbeneath $ zip topdirs (zip relps relparts) of
+               ((topdir, (_relp, dirs)):_)
+                       -- If dir0 is the same as the topdir, don't try to
+                       -- create it, but make sure it does exist.
+                       | null dirs ->
+                               liftIO $ unlessM (doesDirectoryExist (fromRawFilePath topdir)) $
+                                       ioError $ customerror doesNotExistErrorType $
+                                               "createDirectoryFrom: " ++ fromRawFilePath topdir ++ " does not exist"
+                       | otherwise -> createdirs $
+                                       map (topdir P.</>) (reverse (scanl1 (P.</>) dirs))
+               _ -> liftIO $ ioError $ customerror userErrorType
+                       ("createDirectoryFrom: not located in " ++ unwords (map fromRawFilePath topdirs))
   where
        customerror t s = mkIOError t s Nothing (Just (fromRawFilePath dir0))