summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2015-01-09 13:11:56 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2015-01-09 13:11:56 -0400
commit425bc1107aebdb701cdcee44da731dd918cd470d (patch)
tree25bcacb37277b70aa7bd0caaf0fe7c3edc665653
parent20c7644a4d85434cf49840ea92fca0c723710c72 (diff)
revert parentDir change
Reverts 2bba5bc22d049272d3328bfa6c452d3e2e50e86c Unfortunately, this caused breakage on Windows, and possibly elsewhere, because parentDir and takeDirectory do not behave the same when there is a trailing directory separator.
-rw-r--r--Annex/Content.hs6
-rw-r--r--Annex/Content/Direct.hs2
-rw-r--r--Annex/Direct.hs21
-rw-r--r--Annex/Direct/Fixup.hs5
-rw-r--r--Annex/Perms.hs10
-rw-r--r--Annex/ReplaceFile.hs2
-rw-r--r--Annex/Ssh.hs2
-rw-r--r--Assistant.hs4
-rw-r--r--Assistant/Install.hs4
-rw-r--r--Assistant/Install/AutoStart.hs2
-rw-r--r--Assistant/Install/Menu.hs2
-rw-r--r--Assistant/Ssh.hs3
-rw-r--r--Assistant/Threads/UpgradeWatcher.hs2
-rw-r--r--Build/DesktopFile.hs3
-rw-r--r--Build/DistributionUpdate.hs2
-rw-r--r--Build/EvilSplicer.hs2
-rw-r--r--Build/LinuxMkLibs.hs6
-rw-r--r--Build/OSXMkLibs.hs2
-rw-r--r--CmdLine/Seek.hs2
-rw-r--r--Command/AddUrl.hs8
-rw-r--r--Command/Fix.hs2
-rw-r--r--Command/FromKey.hs2
-rw-r--r--Command/Fsck.hs10
-rw-r--r--Command/FuzzTest.hs4
-rw-r--r--Command/Import.hs2
-rw-r--r--Command/ImportFeed.hs2
-rw-r--r--Command/Unlock.hs2
-rw-r--r--Command/Vicfg.hs2
-rw-r--r--Config/Files.hs2
-rw-r--r--Git/Construct.hs4
-rw-r--r--Git/Repair.hs2
-rw-r--r--Locations.hs2
-rw-r--r--Logs/FsckResults.hs2
-rw-r--r--Remote/BitTorrent.hs2
-rw-r--r--Remote/Directory.hs2
-rw-r--r--Remote/GCrypt.hs4
-rw-r--r--Remote/Git.hs2
-rw-r--r--Remote/Rsync.hs4
-rw-r--r--Remote/Tahoe.hs2
-rw-r--r--Test.hs2
-rw-r--r--Upgrade/V1.hs4
-rw-r--r--Utility/Daemon.hs4
-rw-r--r--Utility/FreeDesktop.hs3
-rw-r--r--Utility/LinuxMkLibs.hs4
-rw-r--r--Utility/Path.hs20
45 files changed, 92 insertions, 89 deletions
diff --git a/Annex/Content.hs b/Annex/Content.hs
index 2d52dcefb..37090d3bb 100644
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@@ -261,7 +261,7 @@ finishGetViaTmp check key action = do
prepTmp :: Key -> Annex FilePath
prepTmp key = do
tmp <- fromRepo $ gitAnnexTmpObjectLocation key
- createAnnexDirectory (takeDirectory tmp)
+ createAnnexDirectory (parentDir tmp)
return tmp
{- Creates a temp file for a key, runs an action on it, and cleans up
@@ -425,7 +425,7 @@ cleanObjectLoc key cleaner = do
where
removeparents _ 0 = noop
removeparents file n = do
- let dir = takeDirectory file
+ let dir = parentDir file
maybe noop (const $ removeparents dir (n-1))
<=< catchMaybeIO $ removeDirectory dir
@@ -474,7 +474,7 @@ moveBad key = do
src <- calcRepo $ gitAnnexLocation key
bad <- fromRepo gitAnnexBadDir
let dest = bad </> takeFileName src
- createAnnexDirectory (takeDirectory dest)
+ createAnnexDirectory (parentDir dest)
cleanObjectLoc key $
liftIO $ moveFile src dest
logStatus key InfoMissing
diff --git a/Annex/Content/Direct.hs b/Annex/Content/Direct.hs
index 43defdca3..c09a08f0d 100644
--- a/Annex/Content/Direct.hs
+++ b/Annex/Content/Direct.hs
@@ -247,7 +247,7 @@ sentinalStatus = maybe check return =<< Annex.getState Annex.sentinalstatus
createInodeSentinalFile :: Annex ()
createInodeSentinalFile = unlessM (alreadyexists <||> hasobjects) $ do
s <- annexSentinalFile
- createAnnexDirectory (takeDirectory (sentinalFile s))
+ createAnnexDirectory (parentDir (sentinalFile s))
liftIO $ writeSentinalFile s
where
alreadyexists = liftIO. sentinalFileExists =<< annexSentinalFile
diff --git a/Annex/Direct.hs b/Annex/Direct.hs
index 710227e7e..15eb04060 100644
--- a/Annex/Direct.hs
+++ b/Annex/Direct.hs
@@ -270,7 +270,7 @@ updateWorkTree d oldref = do
- Empty work tree directories are removed, per git behavior. -}
moveout_raw _ _ f = liftIO $ do
nukeFile f
- void $ tryIO $ removeDirectory $ takeDirectory f
+ void $ tryIO $ removeDirectory $ parentDir f
{- If the file is already present, with the right content for the
- key, it's left alone.
@@ -291,7 +291,7 @@ updateWorkTree d oldref = do
movein_raw item makeabs f = do
preserveUnannexed item makeabs f oldref
liftIO $ do
- createDirectoryIfMissing True $ takeDirectory f
+ createDirectoryIfMissing True $ parentDir f
void $ tryIO $ rename (d </> getTopFilePath (DiffTree.file item)) f
{- If the file that's being moved in is already present in the work
@@ -309,14 +309,13 @@ preserveUnannexed item makeabs absf oldref = do
checkdirs (DiffTree.file item)
where
checkdirs from = do
- case parentDir (getTopFilePath from) of
- Nothing -> noop
- Just p -> do
- let d = asTopFilePath p
- let absd = makeabs d
- whenM (liftIO (colliding_nondir absd) <&&> unannexed absd) $
- liftIO $ findnewname absd 0
- checkdirs d
+ let p = parentDir (getTopFilePath from)
+ let d = asTopFilePath p
+ unless (null p) $ do
+ let absd = makeabs d
+ whenM (liftIO (colliding_nondir absd) <&&> unannexed absd) $
+ liftIO $ findnewname absd 0
+ checkdirs d
collidingitem f = isJust
<$> catchMaybeIO (getSymbolicLinkStatus f)
@@ -383,7 +382,7 @@ removeDirect k f = do
)
liftIO $ do
nukeFile f
- void $ tryIO $ removeDirectory $ takeDirectory f
+ void $ tryIO $ removeDirectory $ parentDir f
{- Called when a direct mode file has been changed. Its old content may be
- lost. -}
diff --git a/Annex/Direct/Fixup.hs b/Annex/Direct/Fixup.hs
index 73cefb134..13485242a 100644
--- a/Annex/Direct/Fixup.hs
+++ b/Annex/Direct/Fixup.hs
@@ -10,17 +10,16 @@ module Annex.Direct.Fixup where
import Git.Types
import Git.Config
import qualified Git.Construct as Construct
+import Utility.Path
import Utility.SafeCommand
-import System.FilePath
-
{- Direct mode repos have core.bare=true, but are not really bare.
- Fix up the Repo to be a non-bare repo, and arrange for git commands
- run by git-annex to be passed parameters that override this setting. -}
fixupDirect :: Repo -> IO Repo
fixupDirect r@(Repo { location = l@(Local { gitdir = d, worktree = Nothing }) }) = do
let r' = r
- { location = l { worktree = Just (takeDirectory d) }
+ { location = l { worktree = Just (parentDir d) }
, gitGlobalOpts = gitGlobalOpts r ++
[ Param "-c"
, Param $ coreBare ++ "=" ++ boolConfig False
diff --git a/Annex/Perms.hs b/Annex/Perms.hs
index d314e382c..3430554c7 100644
--- a/Annex/Perms.hs
+++ b/Annex/Perms.hs
@@ -71,12 +71,12 @@ annexFileMode = withShared $ return . go
createAnnexDirectory :: FilePath -> Annex ()
createAnnexDirectory dir = traverse dir [] =<< top
where
- top = takeDirectory <$> fromRepo gitAnnexDir
+ top = parentDir <$> fromRepo gitAnnexDir
traverse d below stop
| d `equalFilePath` stop = done
| otherwise = ifM (liftIO $ doesDirectoryExist d)
( done
- , traverse (takeDirectory d) (d:below) stop
+ , traverse (parentDir d) (d:below) stop
)
where
done = forM_ below $ \p -> do
@@ -92,14 +92,14 @@ freezeContentDir :: FilePath -> Annex ()
freezeContentDir file = unlessM crippledFileSystem $
liftIO . go =<< fromRepo getSharedRepository
where
- dir = takeDirectory file
+ dir = parentDir file
go GroupShared = groupWriteRead dir
go AllShared = groupWriteRead dir
go _ = preventWrite dir
thawContentDir :: FilePath -> Annex ()
thawContentDir file = unlessM crippledFileSystem $
- liftIO $ allowWrite $ takeDirectory file
+ liftIO $ allowWrite $ parentDir file
{- Makes the directory tree to store an annexed file's content,
- with appropriate permissions on each level. -}
@@ -111,7 +111,7 @@ createContentDir dest = do
unlessM crippledFileSystem $
liftIO $ allowWrite dir
where
- dir = takeDirectory dest
+ dir = parentDir dest
{- Creates the content directory for a file if it doesn't already exist,
- or thaws it if it does, then runs an action to modify the file, and
diff --git a/Annex/ReplaceFile.hs b/Annex/ReplaceFile.hs
index 4bb99b370..0355ddd51 100644
--- a/Annex/ReplaceFile.hs
+++ b/Annex/ReplaceFile.hs
@@ -46,5 +46,5 @@ replaceFileFrom src dest = go `catchIO` fallback
where
go = moveFile src dest
fallback _ = do
- createDirectoryIfMissing True $ takeDirectory dest
+ createDirectoryIfMissing True $ parentDir dest
go
diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs
index 2eb8c97dd..15b169862 100644
--- a/Annex/Ssh.hs
+++ b/Annex/Ssh.hs
@@ -125,7 +125,7 @@ prepSocket socketfile = do
-- Cleanup at end of this run.
Annex.addCleanup SshCachingCleanup sshCleanup
- liftIO $ createDirectoryIfMissing True $ takeDirectory socketfile
+ liftIO $ createDirectoryIfMissing True $ parentDir socketfile
lockFileShared $ socket2lock socketfile
enumSocketFiles :: Annex [FilePath]
diff --git a/Assistant.hs b/Assistant.hs
index 0c7aa2c56..2ba778d80 100644
--- a/Assistant.hs
+++ b/Assistant.hs
@@ -78,7 +78,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
logfile <- fromRepo gitAnnexLogFile
liftIO $ debugM desc $ "logging to " ++ logfile
#ifndef mingw32_HOST_OS
- createAnnexDirectory (takeDirectory logfile)
+ createAnnexDirectory (parentDir logfile)
logfd <- liftIO $ handleToFd =<< openLog logfile
if foreground
then do
@@ -98,7 +98,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
-- log file. The only way to do so is to restart the program.
when (foreground || not foreground) $ do
let flag = "GIT_ANNEX_OUTPUT_REDIR"
- createAnnexDirectory (takeDirectory logfile)
+ createAnnexDirectory (parentDir logfile)
ifM (liftIO $ isNothing <$> getEnv flag)
( liftIO $ withFile devNull WriteMode $ \nullh -> do
loghandle <- openLog logfile
diff --git a/Assistant/Install.hs b/Assistant/Install.hs
index e30de173c..e2d52692e 100644
--- a/Assistant/Install.hs
+++ b/Assistant/Install.hs
@@ -49,7 +49,7 @@ ensureInstalled = go =<< standaloneAppBase
go (Just base) = do
let program = base </> "git-annex"
programfile <- programFile
- createDirectoryIfMissing True (takeDirectory programfile)
+ createDirectoryIfMissing True (parentDir programfile)
writeFile programfile program
#ifdef darwin_HOST_OS
@@ -87,7 +87,7 @@ installWrapper :: FilePath -> String -> IO ()
installWrapper file content = do
curr <- catchDefaultIO "" $ readFileStrict file
when (curr /= content) $ do
- createDirectoryIfMissing True (takeDirectory file)
+ createDirectoryIfMissing True (parentDir file)
viaTmp writeFile file content
modifyFileMode file $ addModes [ownerExecuteMode]
diff --git a/Assistant/Install/AutoStart.hs b/Assistant/Install/AutoStart.hs
index 7e1fd2d1f..a49ac32a4 100644
--- a/Assistant/Install/AutoStart.hs
+++ b/Assistant/Install/AutoStart.hs
@@ -19,7 +19,7 @@ import System.FilePath
installAutoStart :: FilePath -> FilePath -> IO ()
installAutoStart command file = do
#ifdef darwin_HOST_OS
- createDirectoryIfMissing True (takeDirectory file)
+ createDirectoryIfMissing True (parentDir file)
writeFile file $ genOSXAutoStartFile osxAutoStartLabel command
["assistant", "--autostart"]
#else
diff --git a/Assistant/Install/Menu.hs b/Assistant/Install/Menu.hs
index 15ef5534d..d095cdd88 100644
--- a/Assistant/Install/Menu.hs
+++ b/Assistant/Install/Menu.hs
@@ -38,7 +38,7 @@ fdoDesktopMenu command = genDesktopEntry
installIcon :: FilePath -> FilePath -> IO ()
installIcon src dest = do
- createDirectoryIfMissing True (takeDirectory dest)
+ createDirectoryIfMissing True (parentDir dest)
withBinaryFile src ReadMode $ \hin ->
withBinaryFile dest WriteMode $ \hout ->
hGetContents hin >>= hPutStr hout
diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs
index fa481a186..7b82f4624 100644
--- a/Assistant/Ssh.hs
+++ b/Assistant/Ssh.hs
@@ -233,8 +233,7 @@ genSshKeyPair = withTmpDir "git-annex-keygen" $ \dir -> do
setupSshKeyPair :: SshKeyPair -> SshData -> IO SshData
setupSshKeyPair sshkeypair sshdata = do
sshdir <- sshDir
- createDirectoryIfMissing True $
- takeDirectory $ sshdir </> sshprivkeyfile
+ createDirectoryIfMissing True $ parentDir $ sshdir </> sshprivkeyfile
unlessM (doesFileExist $ sshdir </> sshprivkeyfile) $
writeFileProtected (sshdir </> sshprivkeyfile) (sshPrivKey sshkeypair)
diff --git a/Assistant/Threads/UpgradeWatcher.hs b/Assistant/Threads/UpgradeWatcher.hs
index 401215999..431e6f339 100644
--- a/Assistant/Threads/UpgradeWatcher.hs
+++ b/Assistant/Threads/UpgradeWatcher.hs
@@ -47,7 +47,7 @@ upgradeWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do
, modifyHook = changed
, delDirHook = changed
}
- let dir = takeDirectory flagfile
+ let dir = parentDir flagfile
let depth = length (splitPath dir) + 1
let nosubdirs f = length (splitPath f) == depth
void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar)
diff --git a/Build/DesktopFile.hs b/Build/DesktopFile.hs
index 5eab68756..6a5838f81 100644
--- a/Build/DesktopFile.hs
+++ b/Build/DesktopFile.hs
@@ -22,7 +22,6 @@ import Assistant.Install.Menu
import Control.Applicative
import System.Directory
import System.Environment
-import System.FilePath
#ifndef mingw32_HOST_OS
import System.Posix.User
#endif
@@ -76,6 +75,6 @@ install command = do
( return ()
, do
programfile <- inDestDir =<< programFile
- createDirectoryIfMissing True (takeDirectory programfile)
+ createDirectoryIfMissing True (parentDir programfile)
writeFile programfile command
)
diff --git a/Build/DistributionUpdate.hs b/Build/DistributionUpdate.hs
index 411121568..6ebe08fb0 100644
--- a/Build/DistributionUpdate.hs
+++ b/Build/DistributionUpdate.hs
@@ -64,7 +64,7 @@ getbuild repodir (url, f) = do
let dest = repodir </> f
let tmp = dest ++ ".tmp"
nukeFile tmp
- createDirectoryIfMissing True (takeDirectory dest)
+ createDirectoryIfMissing True (parentDir dest)
let oops s = do
nukeFile tmp
putStrLn $ "*** " ++ s
diff --git a/Build/EvilSplicer.hs b/Build/EvilSplicer.hs
index 81d4e37c7..fc41c624f 100644
--- a/Build/EvilSplicer.hs
+++ b/Build/EvilSplicer.hs
@@ -204,7 +204,7 @@ applySplices destdir imports splices@(first:_) = do
let f = splicedFile first
let dest = (destdir </> f)
lls <- map (++ "\n") . lines <$> readFileStrictAnyEncoding f
- createDirectoryIfMissing True (takeDirectory dest)
+ createDirectoryIfMissing True (parentDir dest)
let newcontent = concat $ addimports $ expand lls splices
oldcontent <- catchMaybeIO $ readFileStrictAnyEncoding dest
when (oldcontent /= Just newcontent) $ do
diff --git a/Build/LinuxMkLibs.hs b/Build/LinuxMkLibs.hs
index f3a7c3b2e..1ca2fa651 100644
--- a/Build/LinuxMkLibs.hs
+++ b/Build/LinuxMkLibs.hs
@@ -47,7 +47,7 @@ mklibs top = do
writeFile (top </> "linker")
(Prelude.head $ filter ("ld-linux" `isInfixOf`) libs')
writeFile (top </> "gconvdir")
- (takeDirectory $ Prelude.head $ filter ("/gconv/" `isInfixOf`) glibclibs)
+ (parentDir $ Prelude.head $ filter ("/gconv/" `isInfixOf`) glibclibs)
mapM_ (installLinkerShim top) exes
@@ -75,7 +75,7 @@ installLinkerShim top exe = do
symToHardLink :: FilePath -> IO ()
symToHardLink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus f) $ do
l <- readSymbolicLink f
- let absl = absPathFrom (takeDirectory f) l
+ let absl = absPathFrom (parentDir f) l
nukeFile f
createLink absl f
@@ -84,7 +84,7 @@ installFile top f = do
createDirectoryIfMissing True destdir
void $ copyFileExternal CopyTimeStamps f destdir
where
- destdir = inTop top $ takeDirectory f
+ destdir = inTop top $ parentDir f
checkExe :: FilePath -> IO Bool
checkExe f
diff --git a/Build/OSXMkLibs.hs b/Build/OSXMkLibs.hs
index 57f74f0e0..ef668bb4a 100644
--- a/Build/OSXMkLibs.hs
+++ b/Build/OSXMkLibs.hs
@@ -50,7 +50,7 @@ installLibs appbase replacement_libs libmap = do
ifM (doesFileExist dest)
( return Nothing
, do
- createDirectoryIfMissing True (takeDirectory dest)
+ createDirectoryIfMissing True (parentDir dest)
putStrLn $ "installing " ++ pathlib ++ " as " ++ shortlib
_ <- boolSystem "cp" [File pathlib, File dest]
_ <- boolSystem "chmod" [Param "644", File dest]
diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs
index b35e39ba0..9a874807b 100644
--- a/CmdLine/Seek.hs
+++ b/CmdLine/Seek.hs
@@ -70,7 +70,7 @@ withPathContents a params = seekActions $
map a . concat <$> liftIO (mapM get params)
where
get p = ifM (isDirectory <$> getFileStatus p)
- ( map (\f -> (f, makeRelative (takeDirectory p) f))
+ ( map (\f -> (f, makeRelative (parentDir p) f))
<$> dirContentsRecursiveSkipping (".git" `isSuffixOf`) True p
, return [(p, takeFileName p)]
)
diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs
index a5fa53ca0..97adc75ee 100644
--- a/Command/AddUrl.hs
+++ b/Command/AddUrl.hs
@@ -101,7 +101,7 @@ performRemote r relaxed uri file sz = ifAnnexed file adduri geturi
downloadRemoteFile :: Remote -> Bool -> URLString -> FilePath -> Maybe Integer -> Annex (Maybe Key)
downloadRemoteFile r relaxed uri file sz = do
urlkey <- Backend.URL.fromUrl uri sz
- liftIO $ createDirectoryIfMissing True (takeDirectory file)
+ liftIO $ createDirectoryIfMissing True (parentDir file)
ifM (Annex.getState Annex.fast <||> pure relaxed)
( do
cleanup (Remote.uuid r) loguri file urlkey Nothing
@@ -195,7 +195,7 @@ addUrlFileQuvi relaxed quviurl videourl file = do
showOutput
ok <- Transfer.notifyTransfer Transfer.Download (Just file) $
Transfer.download webUUID key (Just file) Transfer.forwardRetry $ const $ do
- liftIO $ createDirectoryIfMissing True (takeDirectory tmp)
+ liftIO $ createDirectoryIfMissing True (parentDir tmp)
downloadUrl [videourl] tmp
if ok
then do
@@ -227,7 +227,7 @@ addUrlChecked relaxed url u checkexistssize key
addUrlFile :: Bool -> URLString -> FilePath -> Annex (Maybe Key)
addUrlFile relaxed url file = do
- liftIO $ createDirectoryIfMissing True (takeDirectory file)
+ liftIO $ createDirectoryIfMissing True (parentDir file)
ifM (Annex.getState Annex.fast <||> pure relaxed)
( nodownload relaxed url file
, downloadWeb url file
@@ -269,7 +269,7 @@ downloadWith downloader dummykey u url file =
where
runtransfer tmp = Transfer.notifyTransfer Transfer.Download (Just file) $
Transfer.download u dummykey (Just file) Transfer.forwardRetry $ \p -> do
- liftIO $ createDirectoryIfMissing True (takeDirectory tmp)
+ liftIO $ createDirectoryIfMissing True (parentDir tmp)
downloader tmp p
{- Hits the url to get the size, if available.
diff --git a/Command/Fix.hs b/Command/Fix.hs
index 956ea4352..774ef8583 100644
--- a/Command/Fix.hs
+++ b/Command/Fix.hs
@@ -43,7 +43,7 @@ perform file link = do
<$> getSymbolicLinkStatus file
#endif
#endif
- createDirectoryIfMissing True (takeDirectory file)
+ createDirectoryIfMissing True (parentDir file)
removeFile file
createSymbolicLink link file
#ifdef WITH_CLIBS
diff --git a/Command/FromKey.hs b/Command/FromKey.hs
index 96da895ed..3b20749fe 100644
--- a/Command/FromKey.hs
+++ b/Command/FromKey.hs
@@ -34,7 +34,7 @@ start _ = error "specify a key and a dest file"
perform :: Key -> FilePath -> CommandPerform
perform key file = do
link <- inRepo $ gitAnnexLink file key
- liftIO $ createDirectoryIfMissing True (takeDirectory file)
+ liftIO $ createDirectoryIfMissing True (parentDir file)
liftIO $ createSymbolicLink link file
next $ cleanup file
diff --git a/Command/Fsck.hs b/Command/Fsck.hs
index 837e68ea8..46c1620f1 100644
--- a/Command/Fsck.hs
+++ b/Command/Fsck.hs
@@ -200,7 +200,7 @@ fixLink key file = do
go want have
| want /= fromInternalGitPath have = do
showNote "fixing link"
- liftIO $ createDirectoryIfMissing True (takeDirectory file)
+ liftIO $ createDirectoryIfMissing True (parentDir file)
liftIO $ removeFile file
addAnnexLink want file
| otherwise = noop
@@ -218,7 +218,7 @@ verifyLocationLog key desc = do
file <- calcRepo $ gitAnnexLocation key
when (present && not direct) $
freezeContent file
- whenM (liftIO $ doesDirectoryExist $ takeDirectory file) $
+ whenM (liftIO $ doesDirectoryExist $ parentDir file) $
freezeContentDir file
{- In direct mode, modified files will show up as not present,
@@ -450,7 +450,7 @@ needFsck _ _ = return True
-}
recordFsckTime :: Key -> Annex ()
recordFsckTime key = do
- parent <- takeDirectory <$> calcRepo (gitAnnexLocation key)
+ parent <- parentDir <$> calcRepo (gitAnnexLocation key)
liftIO $ void $ tryIO $ do
touchFile parent
#ifndef mingw32_HOST_OS
@@ -459,7 +459,7 @@ recordFsckTime key = do
getFsckTime :: Key -> Annex (Maybe EpochTime)
getFsckTime key = do
- parent <- takeDirectory <$> calcRepo (gitAnnexLocation key)
+ parent <- parentDir <$> calcRepo (gitAnnexLocation key)
liftIO $ catchDefaultIO Nothing $ do
s <- getFileStatus parent
return $ if isSticky $ fileMode s
@@ -477,7 +477,7 @@ getFsckTime key = do
recordStartTime :: Annex ()
recordStartTime = do
f <- fromRepo gitAnnexFsckState
- createAnnexDirectory $ takeDirectory f
+ createAnnexDirectory $ parentDir f
liftIO $ do
nukeFile f
withFile f WriteMode $ \h -> do
diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs
index a2a474d31..87bee963f 100644
--- a/Command/FuzzTest.hs
+++ b/Command/FuzzTest.hs
@@ -173,7 +173,7 @@ instance Arbitrary FuzzAction where
runFuzzAction :: FuzzAction -> Annex ()
runFuzzAction (FuzzAdd (FuzzFile f)) = liftIO $ do
- createDirectoryIfMissing True $ takeDirectory f
+ createDirectoryIfMissing True $ parentDir f
n <- getStdRandom random :: IO Int
writeFile f $ show n ++ "\n"
runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $ nukeFile f
@@ -210,7 +210,7 @@ genFuzzAction = do
case md of
Nothing -> genFuzzAction
Just d -> do
- newd <- liftIO $ newDir (takeDirectory $ toFilePath d)
+ newd <- liftIO $ newDir (parentDir $ toFilePath d)
maybe genFuzzAction (return . FuzzMoveDir d) newd
FuzzDeleteDir _ -> do
d <- liftIO existingDir
diff --git a/Command/Import.hs b/Command/Import.hs
index 113df19ac..b20e63853 100644
--- a/Command/Import.hs
+++ b/Command/Import.hs
@@ -88,7 +88,7 @@ start mode (srcfile, destfile) =
next $ return True
importfile = do
handleexisting =<< liftIO (catchMaybeIO $ getSymbolicLinkStatus destfile)
- liftIO $ createDirectoryIfMissing True (takeDirectory destfile)
+ liftIO $ createDirectoryIfMissing True (parentDir destfile)
liftIO $ if mode == Duplicate || mode == SkipDuplicates
then void $ copyFileExternal CopyAllMetaData srcfile destfile
else moveFile srcfile destfile
diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs
index 05dc4f3e4..c45fad961 100644
--- a/Command/ImportFeed.hs
+++ b/Command/ImportFeed.hs
@@ -311,7 +311,7 @@ checkFeedBroken' url f = do
now <- liftIO getCurrentTime
case prev of
Nothing -> do
- createAnnexDirectory (takeDirectory f)
+ createAnnexDirectory (parentDir f)
liftIO $ writeFile f $ show now
return False
Just prevtime -> do
diff --git a/Command/Unlock.hs b/Command/Unlock.hs
index 75df99332..56c4f1dc0 100644
--- a/Command/Unlock.hs
+++ b/Command/Unlock.hs
@@ -46,7 +46,7 @@ perform dest key = ifM (checkDiskSpace Nothing key 0)
( do
src <- calcRepo $ gitAnnexLocation key
tmpdest <- fromRepo $ gitAnnexTmpObjectLocation key
- liftIO $ createDirectoryIfMissing True (takeDirectory tmpdest)
+ liftIO $ createDirectoryIfMissing True (parentDir tmpdest)
showAction "copying"
ifM (liftIO $ copyFileExternal CopyAllMetaData src tmpdest)
( do
diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs
index 12a6084bd..8fc10deb5 100644
--- a/Command/Vicfg.hs
+++ b/Command/Vicfg.hs
@@ -39,7 +39,7 @@ seek = withNothing start
start :: CommandStart
start = do
f <- fromRepo gitAnnexTmpCfgFile
- createAnnexDirectory $ takeDirectory f
+ createAnnexDirectory $ parentDir f
cfg <- getCfg
descs <- uuidDescriptions
liftIO $ writeFileAnyEncoding f $ genCfg cfg descs
diff --git a/Config/Files.hs b/Config/Files.hs
index edea83eeb..8d5c1fd12 100644
--- a/Config/Files.hs
+++ b/Config/Files.hs
@@ -33,7 +33,7 @@ modifyAutoStartFile func = do
let dirs' = nubBy equalFilePath $ func dirs
when (dirs' /= dirs) $ do
f <- autoStartFile
- createDirectoryIfMissing True (takeDirectory f)
+ createDirectoryIfMissing True (parentDir f)
viaTmp writeFile f $ unlines dirs'
{- Adds a directory to the autostart file. If the directory is already
diff --git a/Git/Construct.hs b/Git/Construct.hs
index 0b926342f..108ee7eb7 100644
--- a/Git/Construct.hs
+++ b/Git/Construct.hs
@@ -46,8 +46,8 @@ fromCwd = getCurrentDirectory >>= seekUp
r <- checkForRepo dir
case r of
Nothing -> case parentDir dir of
- Nothing -> return Nothing
- Just d -> seekUp d
+ "" -> return Nothing
+ d -> seekUp d
Just loc -> Just <$> newFrom loc
{- Local Repo constructor, accepts a relative or absolute path. -}
diff --git a/Git/Repair.hs b/Git/Repair.hs
index 2930b9a0c..bee9f2b50 100644
--- a/Git/Repair.hs
+++ b/Git/Repair.hs
@@ -244,7 +244,7 @@ explodePackedRefsFile r = do
where
makeref (sha, ref) = do
let dest = localGitDir r </> fromRef ref
- createDirectoryIfMissing True (takeDirectory dest)
+ createDirectoryIfMissing True (parentDir dest)
unlessM (doesFileExist dest) $
writeFile dest (fromRef sha)
diff --git a/Locations.hs b/Locations.hs
index 02758eb05..614cbdde3 100644
--- a/Locations.hs
+++ b/Locations.hs
@@ -146,7 +146,7 @@ gitAnnexLink file key r = do
currdir <- getCurrentDirectory
let absfile = fromMaybe whoops $ absNormPathUnix currdir file
loc <- gitAnnexLocation' key r False
- relPathDirToFile (takeDirectory absfile) loc
+ relPathDirToFile (parentDir absfile) loc
where
whoops = error $ "unable to normalize " ++ file
diff --git a/Logs/FsckResults.hs b/Logs/FsckResults.hs
index 00a36fa5c..23367a3d3 100644
--- a/Logs/FsckResults.hs
+++ b/Logs/FsckResults.hs
@@ -29,7 +29,7 @@ writeFsckResults u fsckresults = do
| otherwise -> store s t logfile
where
store s t logfile = do
- createDirectoryIfMissing True (takeDirectory logfile)
+ createDirectoryIfMissing True (parentDir logfile)
liftIO $ viaTmp writeFile logfile $ serialize s t
serialize s t =
let ls = map fromRef (S.toList s)
diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs
index b04abe56b..d0a35fa30 100644
--- a/Remote/BitTorrent.hs
+++ b/Remote/BitTorrent.hs
@@ -189,7 +189,7 @@ downloadTorrentFile u = do
, do
showAction "downloading torrent file"
showOutput
- createAnnexDirectory (takeDirectory torrent)
+ createAnnexDirectory (parentDir torrent)
if isTorrentMagnetUrl u
then do
tmpdir <- tmpTorrentDir u
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 1d9a15ea5..66a3de49f 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -143,7 +143,7 @@ finalizeStoreGeneric :: FilePath -> FilePath -> IO ()
finalizeStoreGeneric tmp dest = do
void $ tryIO $ allowWrite dest -- may already exist
void $ tryIO $ removeDirectoryRecursive dest -- or not exist
- createDirectoryIfMissing True (takeDirectory dest)
+ createDirectoryIfMissing True (parentDir dest)
renameDirectory tmp dest
-- may fail on some filesystems
void $ tryIO $ do
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 67021732f..2f2ddc9f3 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -315,7 +315,7 @@ store r rsyncopts
void $ tryIO $ createDirectoryIfMissing True tmpdir
let tmpf = tmpdir </> keyFile k
meteredWriteFile p tmpf b
- let destdir = takeDirectory $ gCryptLocation r k
+ let destdir = parentDir $ gCryptLocation r k
Remote.Directory.finalizeStoreGeneric tmpdir destdir
return True
| Git.repoIsSsh (repo r) = if isShell r
@@ -340,7 +340,7 @@ retrieve r rsyncopts
remove :: Remote -> Remote.Rsync.RsyncOpts -> Remover
remove r rsyncopts k
| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $
- liftIO $ Remote.Directory.removeDirGeneric (Git.repoLocation (repo r)) (takeDirectory (gCryptLocation r k))
+ liftIO $ Remote.Directory.removeDirGeneric (Git.repoLocation (repo r)) (parentDir (gCryptLocation r k))
| Git.repoIsSsh (repo r) = shellOrRsync r removeshell removersync
| otherwise = unsupportedUrl
where
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 8e521cfe9..17b44fa6e 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -556,7 +556,7 @@ rsyncOrCopyFile rsyncparams src dest p =
ifM (sameDeviceIds src dest) (docopy, dorsync)
where
sameDeviceIds a b = (==) <$> getDeviceId a <*> getDeviceId b
- getDeviceId f = deviceID <$> liftIO (getFileStatus $ takeDirectory f)
+ getDeviceId f = deviceID <$> liftIO (getFileStatus $ parentDir f)
docopy = liftIO $ bracket
(forkIO $ watchfilesize zeroBytesProcessed)
(void . tryIO . killThread)
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 72cabe2fd..ad5b77d38 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -161,7 +161,7 @@ rsyncSetup mu _ c = do
store :: RsyncOpts -> Key -> FilePath -> MeterUpdate -> Annex Bool
store o k src meterupdate = withRsyncScratchDir $ \tmp -> do
let dest = tmp </> Prelude.head (keyPaths k)
- liftIO $ createDirectoryIfMissing True $ takeDirectory dest
+ liftIO $ createDirectoryIfMissing True $ parentDir dest
ok <- liftIO $ if canrename
then do
rename src dest
@@ -214,7 +214,7 @@ remove o k = do
- traverses directories. -}
includes = concatMap use annexHashes
use h = let dir = h k in
- [ takeDirectory dir
+ [ parentDir dir
, dir
-- match content directory and anything in it
, dir </> keyFile k </> "***"
diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs
index 06c7590e7..27bb12884 100644
--- a/Remote/Tahoe.hs
+++ b/Remote/Tahoe.hs
@@ -153,7 +153,7 @@ tahoeConfigure configdir furl mscs = do
createClient :: TahoeConfigDir -> IntroducerFurl -> IO Bool
createClient configdir furl = do
- createDirectoryIfMissing True (takeDirectory configdir)
+ createDirectoryIfMissing True (parentDir configdir)
boolTahoe configdir "create-client"
[ Param "--nickname", Param "git-annex"
, Param "--introducer", Param furl
diff --git a/Test.hs b/Test.hs
index 2905c5ce2..dd12997ff 100644
--- a/Test.hs
+++ b/Test.hs
@@ -1071,7 +1071,7 @@ test_uncommitted_conflict_resolution = do
withtmpclonerepo False $ \r2 -> do
indir r1 $ do
disconnectOrigin
- createDirectoryIfMissing True (takeDirectory remoteconflictor)
+ createDirectoryIfMissing True (parentDir remoteconflictor)
writeFile remoteconflictor annexedcontent
git_annex "add" [conflictor] @? "add remoteconflicter failed"
git_annex "sync" [] @? "sync failed in r1"
diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs
index 7113509fe..347b102ac 100644
--- a/Upgrade/V1.hs
+++ b/Upgrade/V1.hs
@@ -73,7 +73,7 @@ moveContent = do
where
move f = do
let k = fileKey1 (takeFileName f)
- let d = takeDirectory f
+ let d = parentDir f
liftIO $ allowWrite d
liftIO $ allowWrite f
moveAnnex k f
@@ -114,7 +114,7 @@ moveLocationLogs = do
dest <- fromRepo $ logFile2 k
dir <- fromRepo Upgrade.V2.gitStateDir
let f = dir </> l
- liftIO $ createDirectoryIfMissing True (takeDirectory dest)
+ liftIO $ createDirectoryIfMissing True (parentDir dest)
-- could just git mv, but this way deals with
-- log files that are not checked into git,
-- as well as merging with already upgraded
diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs
index 961b098dc..d1f539e98 100644
--- a/Utility/Daemon.hs
+++ b/Utility/Daemon.hs
@@ -83,7 +83,7 @@ foreground pidfile a = do
- Fails if the pid file is already locked by another process. -}
lockPidFile :: FilePath -> IO ()
lockPidFile pidfile = do
- createDirectoryIfMissing True (takeDirectory pidfile)
+ createDirectoryIfMissing True (parentDir pidfile)
#ifndef mingw32_HOST_OS
fd <- openFd pidfile ReadWrite (Just stdFileMode) defaultFileFlags
locked <- catchMaybeIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
@@ -176,6 +176,6 @@ winLockFile pid pidfile = do
prefix = pidfile ++ "."
suffix = ".lck"
cleanstale = mapM_ (void . tryIO . removeFile) =<<
- (filter iswinlockfile <$> dirContents (takeDirectory pidfile))
+ (filter iswinlockfile <$> dirContents (parentDir pidfile))
iswinlockfile f = suffix `isSuffixOf` f && prefix `isPrefixOf` f
#endif
diff --git a/Utility/FreeDesktop.hs b/Utility/FreeDesktop.hs
index 208a392e9..c1f042ce8 100644
--- a/Utility/FreeDesktop.hs
+++ b/Utility/FreeDesktop.hs
@@ -27,6 +27,7 @@ module Utility.FreeDesktop (
) where
import Utility.Exception
+import Utility.Path
import Utility.UserInfo
import Utility.Process
import Utility.PartialPrelude
@@ -78,7 +79,7 @@ buildDesktopMenuFile d = unlines ("[Desktop Entry]" : map keyvalue d) ++ "\n"
writeDesktopMenuFile :: DesktopEntry -> String -> IO ()
writeDesktopMenuFile d file = do
- createDirectoryIfMissing True (takeDirectory file)
+ createDirectoryIfMissing True (parentDir file)
writeFile file $ buildDesktopMenuFile d
{- Path to use for a desktop menu file, in either the systemDataDir or
diff --git a/Utility/LinuxMkLibs.hs b/Utility/LinuxMkLibs.hs
index 2482a9bca..aaafd8d0c 100644
--- a/Utility/LinuxMkLibs.hs
+++ b/Utility/LinuxMkLibs.hs
@@ -29,13 +29,13 @@ installLib installfile top lib = ifM (doesFileExist lib)
( do
installfile top lib
checksymlink lib
- return $ Just $ takeDirectory lib
+ return $ Just $ parentDir lib
, return Nothing
)
where
checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do
l <- readSymbolicLink (inTop top f)
- let absl = absPathFrom (takeDirectory f) l
+ let absl = absPathFrom (parentDir f) l
target <- relPathDirToFile (takeDirectory f) absl
installfile top absl
nukeFile (top ++ f)
diff --git a/Utility/Path.hs b/Utility/Path.hs
index cc6c35485..763654db2 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -77,12 +77,18 @@ absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos
todos = replace "/" "\\"
#endif
-{- Just the parent directory of a path, or Nothing if the path has no
- - parent (ie for "/") -}
-parentDir :: FilePath -> Maybe FilePath
+{- Returns the parent directory of a path.
+ -
+ - To allow this to be easily used in loops, which terminate upon reaching the
+ - top, the parent of / is ""
+ -
+ - An additional subtle difference between this and takeDirectory
+ - is that takeDirectory "foo/bar/" is "foo/bar", while parentDir is "foo"
+ -}
+parentDir :: FilePath -> FilePath
parentDir dir
- | null dirs = Nothing
- | otherwise = Just $ joinDrive drive (join s $ init dirs)
+ | null dirs = ""
+ | otherwise = joinDrive drive (join s $ init dirs)
where
-- on Unix, the drive will be "/" when the dir is absolute, otherwise ""
(drive, path) = splitDrive dir
@@ -92,8 +98,8 @@ parentDir dir
prop_parentDir_basics :: FilePath -> Bool
prop_parentDir_basics dir
| null dir = True
- | dir == "/" = parentDir dir == Nothing
- | otherwise = p /= Just dir
+ | dir == "/" = parentDir dir == ""
+ | otherwise = p /= dir
where
p = parentDir dir