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:
parent
d09a198ec0
commit
965e106f24
47 changed files with 97 additions and 96 deletions
|
@ -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]
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue