diff options
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 @@ -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 |