diff options
45 files changed, 90 insertions, 89 deletions
diff --git a/Annex/Content.hs b/Annex/Content.hs index 37090d3bb..2d52dcefb 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 (parentDir tmp) + createAnnexDirectory (takeDirectory 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 = parentDir file + let dir = takeDirectory 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 (parentDir dest) + createAnnexDirectory (takeDirectory dest) cleanObjectLoc key $ liftIO $ moveFile src dest logStatus key InfoMissing diff --git a/Annex/Content/Direct.hs b/Annex/Content/Direct.hs index d9e1535f3..a2df9f6d3 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 (parentDir (sentinalFile s)) + createAnnexDirectory (takeDirectory (sentinalFile s)) liftIO $ writeSentinalFile s where alreadyexists = liftIO. sentinalFileExists =<< annexSentinalFile diff --git a/Annex/Direct.hs b/Annex/Direct.hs index e4015dd16..6292f027f 100644 --- a/Annex/Direct.hs +++ b/Annex/Direct.hs @@ -267,7 +267,7 @@ updateWorkTree d oldref = do - Empty work tree directories are removed, per git behavior. -} moveout_raw _ _ f = liftIO $ do nukeFile f - void $ tryIO $ removeDirectory $ parentDir f + void $ tryIO $ removeDirectory $ takeDirectory f {- If the file is already present, with the right content for the - key, it's left alone. @@ -288,7 +288,7 @@ updateWorkTree d oldref = do movein_raw item makeabs f = do preserveUnannexed item makeabs f oldref liftIO $ do - createDirectoryIfMissing True $ parentDir f + createDirectoryIfMissing True $ takeDirectory f void $ tryIO $ rename (d </> getTopFilePath (DiffTree.file item)) f {- If the file that's being moved in is already present in the work @@ -306,13 +306,14 @@ preserveUnannexed item makeabs absf oldref = do checkdirs (DiffTree.file item) where checkdirs from = do - 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 + 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 collidingitem f = isJust <$> catchMaybeIO (getSymbolicLinkStatus f) @@ -379,7 +380,7 @@ removeDirect k f = do ) liftIO $ do nukeFile f - void $ tryIO $ removeDirectory $ parentDir f + void $ tryIO $ removeDirectory $ takeDirectory 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 13485242a..73cefb134 100644 --- a/Annex/Direct/Fixup.hs +++ b/Annex/Direct/Fixup.hs @@ -10,16 +10,17 @@ 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 (parentDir d) } + { location = l { worktree = Just (takeDirectory d) } , gitGlobalOpts = gitGlobalOpts r ++ [ Param "-c" , Param $ coreBare ++ "=" ++ boolConfig False diff --git a/Annex/Perms.hs b/Annex/Perms.hs index 3430554c7..d314e382c 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 = parentDir <$> fromRepo gitAnnexDir + top = takeDirectory <$> fromRepo gitAnnexDir traverse d below stop | d `equalFilePath` stop = done | otherwise = ifM (liftIO $ doesDirectoryExist d) ( done - , traverse (parentDir d) (d:below) stop + , traverse (takeDirectory 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 = parentDir file + dir = takeDirectory file go GroupShared = groupWriteRead dir go AllShared = groupWriteRead dir go _ = preventWrite dir thawContentDir :: FilePath -> Annex () thawContentDir file = unlessM crippledFileSystem $ - liftIO $ allowWrite $ parentDir file + liftIO $ allowWrite $ takeDirectory 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 = parentDir dest + dir = takeDirectory 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 0355ddd51..4bb99b370 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 $ parentDir dest + createDirectoryIfMissing True $ takeDirectory dest go diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index 15b169862..2eb8c97dd 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 $ parentDir socketfile + liftIO $ createDirectoryIfMissing True $ takeDirectory socketfile lockFileShared $ socket2lock socketfile enumSocketFiles :: Annex [FilePath] diff --git a/Assistant.hs b/Assistant.hs index 2ba778d80..0c7aa2c56 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 (parentDir logfile) + createAnnexDirectory (takeDirectory 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 (parentDir logfile) + createAnnexDirectory (takeDirectory 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 e2d52692e..e30de173c 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 (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] diff --git a/Assistant/Install/AutoStart.hs b/Assistant/Install/AutoStart.hs index b03d20224..7e0c7507b 100644 --- a/Assistant/Install/AutoStart.hs +++ b/Assistant/Install/AutoStart.hs @@ -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 diff --git a/Assistant/Install/Menu.hs b/Assistant/Install/Menu.hs index d095cdd88..15ef5534d 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 (parentDir dest) + createDirectoryIfMissing True (takeDirectory dest) withBinaryFile src ReadMode $ \hin -> withBinaryFile dest WriteMode $ \hout -> hGetContents hin >>= hPutStr hout diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs index 7b82f4624..fa481a186 100644 --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -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) diff --git a/Assistant/Threads/UpgradeWatcher.hs b/Assistant/Threads/UpgradeWatcher.hs index 431e6f339..401215999 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 = 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) diff --git a/Build/DesktopFile.hs b/Build/DesktopFile.hs index 6a5838f81..5eab68756 100644 --- a/Build/DesktopFile.hs +++ b/Build/DesktopFile.hs @@ -22,6 +22,7 @@ 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 @@ -75,6 +76,6 @@ install command = do ( return () , do programfile <- inDestDir =<< programFile - createDirectoryIfMissing True (parentDir programfile) + createDirectoryIfMissing True (takeDirectory programfile) writeFile programfile command ) diff --git a/Build/DistributionUpdate.hs b/Build/DistributionUpdate.hs index 2058f4be4..d7fb373c8 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 (parentDir dest) + createDirectoryIfMissing True (takeDirectory dest) let oops s = do nukeFile tmp putStrLn $ "*** " ++ s diff --git a/Build/EvilSplicer.hs b/Build/EvilSplicer.hs index fc41c624f..81d4e37c7 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 (parentDir dest) + createDirectoryIfMissing True (takeDirectory 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 1ca2fa651..f3a7c3b2e 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") - (parentDir $ Prelude.head $ filter ("/gconv/" `isInfixOf`) glibclibs) + (takeDirectory $ 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 (parentDir f) l + let absl = absPathFrom (takeDirectory 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 $ parentDir f + destdir = inTop top $ takeDirectory f checkExe :: FilePath -> IO Bool checkExe f diff --git a/Build/OSXMkLibs.hs b/Build/OSXMkLibs.hs index ef668bb4a..57f74f0e0 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 (parentDir dest) + createDirectoryIfMissing True (takeDirectory 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 9a874807b..b35e39ba0 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 (parentDir p) f)) + ( map (\f -> (f, makeRelative (takeDirectory p) f)) <$> dirContentsRecursiveSkipping (".git" `isSuffixOf`) True p , return [(p, takeFileName p)] ) diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 97adc75ee..a5fa53ca0 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 (parentDir file) + liftIO $ createDirectoryIfMissing True (takeDirectory 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 (parentDir tmp) + liftIO $ createDirectoryIfMissing True (takeDirectory 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 (parentDir file) + liftIO $ createDirectoryIfMissing True (takeDirectory 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 (parentDir tmp) + liftIO $ createDirectoryIfMissing True (takeDirectory tmp) downloader tmp p {- Hits the url to get the size, if available. diff --git a/Command/Fix.hs b/Command/Fix.hs index 774ef8583..956ea4352 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -43,7 +43,7 @@ perform file link = do <$> getSymbolicLinkStatus file #endif #endif - createDirectoryIfMissing True (parentDir file) + createDirectoryIfMissing True (takeDirectory file) removeFile file createSymbolicLink link file #ifdef WITH_CLIBS diff --git a/Command/FromKey.hs b/Command/FromKey.hs index 3b20749fe..96da895ed 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 (parentDir file) + liftIO $ createDirectoryIfMissing True (takeDirectory file) liftIO $ createSymbolicLink link file next $ cleanup file diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 46c1620f1..837e68ea8 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 (parentDir file) + liftIO $ createDirectoryIfMissing True (takeDirectory 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 $ parentDir file) $ + whenM (liftIO $ doesDirectoryExist $ takeDirectory 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 <- parentDir <$> calcRepo (gitAnnexLocation key) + parent <- takeDirectory <$> 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 <- parentDir <$> calcRepo (gitAnnexLocation key) + parent <- takeDirectory <$> 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 $ parentDir f + createAnnexDirectory $ takeDirectory f liftIO $ do nukeFile f withFile f WriteMode $ \h -> do diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs index 87bee963f..a2a474d31 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 $ parentDir f + createDirectoryIfMissing True $ takeDirectory 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 (parentDir $ toFilePath d) + newd <- liftIO $ newDir (takeDirectory $ toFilePath d) maybe genFuzzAction (return . FuzzMoveDir d) newd FuzzDeleteDir _ -> do d <- liftIO existingDir diff --git a/Command/Import.hs b/Command/Import.hs index b20e63853..113df19ac 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 (parentDir destfile) + liftIO $ createDirectoryIfMissing True (takeDirectory 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 c45fad961..05dc4f3e4 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 (parentDir f) + createAnnexDirectory (takeDirectory f) liftIO $ writeFile f $ show now return False Just prevtime -> do diff --git a/Command/Unlock.hs b/Command/Unlock.hs index 56c4f1dc0..75df99332 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 (parentDir tmpdest) + liftIO $ createDirectoryIfMissing True (takeDirectory tmpdest) showAction "copying" ifM (liftIO $ copyFileExternal CopyAllMetaData src tmpdest) ( do diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs index 8fc10deb5..12a6084bd 100644 --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -39,7 +39,7 @@ seek = withNothing start start :: CommandStart start = do f <- fromRepo gitAnnexTmpCfgFile - createAnnexDirectory $ parentDir f + createAnnexDirectory $ takeDirectory f cfg <- getCfg descs <- uuidDescriptions liftIO $ writeFileAnyEncoding f $ genCfg cfg descs diff --git a/Config/Files.hs b/Config/Files.hs index 8d5c1fd12..edea83eeb 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 (parentDir f) + createDirectoryIfMissing True (takeDirectory 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 eed2b9930..3c6013ac1 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 - "" -> return Nothing - d -> seekUp d + Nothing -> return Nothing + Just 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 77a592b4e..573113883 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -241,7 +241,7 @@ explodePackedRefsFile r = do where makeref (sha, ref) = do let dest = localGitDir r </> fromRef ref - createDirectoryIfMissing True (parentDir dest) + createDirectoryIfMissing True (takeDirectory dest) unlessM (doesFileExist dest) $ writeFile dest (fromRef sha) diff --git a/Locations.hs b/Locations.hs index bcf793bda..5ebbbd631 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 - return $ relPathDirToFile (parentDir absfile) loc + return $ relPathDirToFile (takeDirectory absfile) loc where whoops = error $ "unable to normalize " ++ file diff --git a/Logs/FsckResults.hs b/Logs/FsckResults.hs index 23367a3d3..00a36fa5c 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 (parentDir logfile) + createDirectoryIfMissing True (takeDirectory 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 d0a35fa30..b04abe56b 100644 --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -189,7 +189,7 @@ downloadTorrentFile u = do , do showAction "downloading torrent file" showOutput - createAnnexDirectory (parentDir torrent) + createAnnexDirectory (takeDirectory torrent) if isTorrentMagnetUrl u then do tmpdir <- tmpTorrentDir u diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 66a3de49f..1d9a15ea5 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 (parentDir dest) + createDirectoryIfMissing True (takeDirectory dest) renameDirectory tmp dest -- may fail on some filesystems void $ tryIO $ do diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index 2f2ddc9f3..67021732f 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 = parentDir $ gCryptLocation r k + let destdir = takeDirectory $ 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)) (parentDir (gCryptLocation r k)) + liftIO $ Remote.Directory.removeDirGeneric (Git.repoLocation (repo r)) (takeDirectory (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 17b44fa6e..8e521cfe9 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 $ parentDir f) + getDeviceId f = deviceID <$> liftIO (getFileStatus $ takeDirectory f) docopy = liftIO $ bracket (forkIO $ watchfilesize zeroBytesProcessed) (void . tryIO . killThread) diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index ad5b77d38..72cabe2fd 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 $ parentDir dest + liftIO $ createDirectoryIfMissing True $ takeDirectory 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 - [ parentDir dir + [ takeDirectory dir , dir -- match content directory and anything in it , dir </> keyFile k </> "***" diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs index 27bb12884..06c7590e7 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 (parentDir configdir) + createDirectoryIfMissing True (takeDirectory configdir) boolTahoe configdir "create-client" [ Param "--nickname", Param "git-annex" , Param "--introducer", Param furl @@ -1069,7 +1069,7 @@ test_uncommitted_conflict_resolution = do withtmpclonerepo False $ \r2 -> do indir r1 $ do disconnectOrigin - createDirectoryIfMissing True (parentDir remoteconflictor) + createDirectoryIfMissing True (takeDirectory 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 347b102ac..7113509fe 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 = parentDir f + let d = takeDirectory 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 (parentDir dest) + liftIO $ createDirectoryIfMissing True (takeDirectory 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 d1f539e98..961b098dc 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 (parentDir pidfile) + createDirectoryIfMissing True (takeDirectory 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 (parentDir pidfile)) + (filter iswinlockfile <$> dirContents (takeDirectory pidfile)) iswinlockfile f = suffix `isSuffixOf` f && prefix `isPrefixOf` f #endif diff --git a/Utility/FreeDesktop.hs b/Utility/FreeDesktop.hs index c1f042ce8..208a392e9 100644 --- a/Utility/FreeDesktop.hs +++ b/Utility/FreeDesktop.hs @@ -27,7 +27,6 @@ module Utility.FreeDesktop ( ) where import Utility.Exception -import Utility.Path import Utility.UserInfo import Utility.Process import Utility.PartialPrelude @@ -79,7 +78,7 @@ buildDesktopMenuFile d = unlines ("[Desktop Entry]" : map keyvalue d) ++ "\n" writeDesktopMenuFile :: DesktopEntry -> String -> IO () writeDesktopMenuFile d file = do - createDirectoryIfMissing True (parentDir file) + createDirectoryIfMissing True (takeDirectory 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 1dc4e1ea3..14b170fa0 100644 --- a/Utility/LinuxMkLibs.hs +++ b/Utility/LinuxMkLibs.hs @@ -28,14 +28,14 @@ installLib installfile top lib = ifM (doesFileExist lib) ( do installfile top lib checksymlink lib - return $ Just $ parentDir lib + return $ Just $ takeDirectory lib , return Nothing ) where checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do l <- readSymbolicLink (inTop top f) - let absl = absPathFrom (parentDir f) l - let target = relPathDirToFile (parentDir f) absl + let absl = absPathFrom (takeDirectory f) l + let target = relPathDirToFile (takeDirectory f) absl installfile top absl nukeFile (top ++ f) createSymbolicLink target (inTop top f) diff --git a/Utility/Path.hs b/Utility/Path.hs index c3e893d16..7f0349125 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -77,14 +77,12 @@ absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos todos = replace "/" "\\" #endif -{- 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 "" -} -parentDir :: FilePath -> FilePath +{- Just the parent directory of a path, or Nothing if the path has no + - parent (ie for "/") -} +parentDir :: FilePath -> Maybe FilePath parentDir dir - | null dirs = "" - | otherwise = joinDrive drive (join s $ init dirs) + | null dirs = Nothing + | otherwise = Just $ joinDrive drive (join s $ init dirs) where -- on Unix, the drive will be "/" when the dir is absolute, otherwise "" (drive, path) = splitDrive dir @@ -94,8 +92,8 @@ parentDir dir prop_parentDir_basics :: FilePath -> Bool prop_parentDir_basics dir | null dir = True - | dir == "/" = parentDir dir == "" - | otherwise = p /= dir + | dir == "/" = parentDir dir == Nothing + | otherwise = p /= Just dir where p = parentDir dir |