made parentDir return a Maybe FilePath; removed most uses of it

parentDir is less safe than takeDirectory, especially when working
with relative FilePaths. It's really only useful in loops that
want to terminate at /

This commit was sponsored by Audric SCHILTKNECHT.
This commit is contained in:
Joey Hess 2015-01-06 18:29:07 -04:00
parent d09a198ec0
commit 965e106f24
47 changed files with 97 additions and 96 deletions

View file

@ -49,7 +49,7 @@ ensureInstalled = go =<< standaloneAppBase
go (Just base) = do
let program = base </> "git-annex"
programfile <- programFile
createDirectoryIfMissing True (parentDir programfile)
createDirectoryIfMissing True (takeDirectory 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 (parentDir file)
createDirectoryIfMissing True (takeDirectory file)
viaTmp writeFile file content
modifyFileMode file $ addModes [ownerExecuteMode]

View file

@ -19,7 +19,7 @@ import System.Directory
installAutoStart :: FilePath -> FilePath -> IO ()
installAutoStart command file = do
#ifdef darwin_HOST_OS
createDirectoryIfMissing True (parentDir file)
createDirectoryIfMissing True (takeDirectory file)
writeFile file $ genOSXAutoStartFile osxAutoStartLabel command
["assistant", "--autostart"]
#else

View file

@ -38,7 +38,7 @@ fdoDesktopMenu command = genDesktopEntry
installIcon :: FilePath -> FilePath -> IO ()
installIcon src dest = do
createDirectoryIfMissing True (parentDir dest)
createDirectoryIfMissing True (takeDirectory dest)
withBinaryFile src ReadMode $ \hin ->
withBinaryFile dest WriteMode $ \hout ->
hGetContents hin >>= hPutStr hout

View file

@ -233,7 +233,8 @@ genSshKeyPair = withTmpDir "git-annex-keygen" $ \dir -> do
setupSshKeyPair :: SshKeyPair -> SshData -> IO SshData
setupSshKeyPair sshkeypair sshdata = do
sshdir <- sshDir
createDirectoryIfMissing True $ parentDir $ sshdir </> sshprivkeyfile
createDirectoryIfMissing True $
takeDirectory $ sshdir </> sshprivkeyfile
unlessM (doesFileExist $ sshdir </> sshprivkeyfile) $
writeFileProtected (sshdir </> sshprivkeyfile) (sshPrivKey sshkeypair)

View file

@ -47,7 +47,7 @@ upgradeWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do
, modifyHook = changed
, delDirHook = changed
}
let dir = parentDir flagfile
let dir = takeDirectory flagfile
let depth = length (splitPath dir) + 1
let nosubdirs f = length (splitPath f) == depth
void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar)

View file

@ -161,7 +161,7 @@ upgradeToDistribution newdir cleanup distributionfile = do
{- OS X uses a dmg, so mount it, and copy the contents into place. -}
unpack = liftIO $ do
olddir <- oldVersionLocation
withTmpDirIn (parentDir newdir) "git-annex.upgrade" $ \tmpdir -> do
withTmpDirIn (takeDirectory newdir) "git-annex.upgrade" $ \tmpdir -> do
void $ boolSystem "hdiutil"
[ Param "attach", File distributionfile
, Param "-mountpoint", File tmpdir
@ -186,7 +186,7 @@ upgradeToDistribution newdir cleanup distributionfile = do
- into place. -}
unpack = liftIO $ do
olddir <- oldVersionLocation
withTmpDirIn (parentDir newdir) "git-annex.upgrade" $ \tmpdir -> do
withTmpDirIn (takeDirectory newdir) "git-annex.upgrade" $ \tmpdir -> do
let tarball = tmpdir </> "tar"
-- Cannot rely on filename extension, and this also
-- avoids problems if tar doesn't support transparent
@ -217,14 +217,14 @@ upgradeToDistribution newdir cleanup distributionfile = do
unlessM (doesDirectoryExist dir) $
error $ "did not find " ++ dir ++ " in " ++ distributionfile
makeorigsymlink olddir = do
let origdir = parentDir olddir </> installBase
let origdir = takeDirectory olddir </> installBase
nukeFile origdir
createSymbolicLink newdir origdir
{- Finds where the old version was installed. -}
oldVersionLocation :: IO FilePath
oldVersionLocation = do
pdir <- parentDir <$> readProgramFile
pdir <- takeDirectory <$> readProgramFile
#ifdef darwin_HOST_OS
let dirs = splitDirectories pdir
{- It will probably be deep inside a git-annex.app directory. -}
@ -253,7 +253,7 @@ newVersionLocation d olddir =
return Nothing
where
s = installBase ++ "." ++ distributionVersion d
topdir = parentDir olddir
topdir = takeDirectory olddir
newloc = topdir </> s
trymkdir dir fallback =
(createDirectory dir >> return (Just dir))

View file

@ -83,7 +83,7 @@ checkRepositoryPath p = do
home <- myHomeDir
let basepath = expandTilde home $ T.unpack p
path <- absPath basepath
let parent = parentDir path
let parent = takeDirectory path
problems <- catMaybes <$> mapM runcheck
[ (return $ path == "/", "Enter the full path to use for the repository.")
, (return $ all isSpace basepath, "A blank path? Seems unlikely.")
@ -416,7 +416,7 @@ startFullAssistant path repogroup setup = do
canWrite :: FilePath -> IO Bool
canWrite dir = do
tocheck <- ifM (doesDirectoryExist dir)
(return dir, return $ parentDir dir)
(return dir, return $ takeDirectory dir)
catchBoolIO $ fileAccess tocheck False True False
{- Gets the UUID of the git repo at a location, which may not exist, or