From e505c03bccdc6567cd517a6ddaf70a411489473d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 29 Oct 2020 10:33:12 -0400 Subject: [PATCH] more RawFilePath conversion nukeFile replaced with removeWhenExistsWith removeLink, which allows using RawFilePath. Utility.Directory cannot use RawFilePath since setup does not depend on posix. This commit was sponsored by Graham Spencer on Patreon. --- Annex/AutoMerge.hs | 4 +- Annex/Branch.hs | 2 +- Annex/Content.hs | 16 +++---- Annex/Content/PointerFile.hs | 7 +-- Annex/Fixup.hs | 5 +-- Annex/Ingest.hs | 6 +-- Annex/Init.hs | 16 +++---- Annex/Locations.hs | 8 ++-- Annex/LockFile.hs | 12 ++--- Annex/Ssh.hs | 2 +- Annex/Tmp.hs | 2 +- Annex/View.hs | 2 +- Assistant/Repair.hs | 2 +- Assistant/Restart.hs | 4 +- Assistant/Threads/SanityChecker.hs | 4 +- Assistant/Upgrade.hs | 6 +-- Build/DistributionUpdate.hs | 8 ++-- Build/LinuxMkLibs.hs | 4 +- Build/Standalone.hs | 4 +- Command/AddUrl.hs | 4 +- Command/DropUnused.hs | 2 +- Command/Fsck.hs | 5 ++- Command/FuzzTest.hs | 3 +- Command/Import.hs | 4 +- Command/Lock.hs | 2 +- Command/Multicast.hs | 4 +- Command/P2P.hs | 2 +- Command/Repair.hs | 2 +- Command/Undo.hs | 2 +- Command/Vicfg.hs | 2 +- Config.hs | 2 +- Creds.hs | 2 +- Git/Repair.hs | 15 ++++--- Logs/FsckResults.hs | 5 ++- P2P/IO.hs | 2 +- Remote/BitTorrent.hs | 2 +- Remote/Directory.hs | 2 +- Remote/Directory/LegacyChunked.hs | 2 +- Remote/Helper/Special.hs | 4 +- Test.hs | 13 +++--- Types/LockCache.hs | 6 ++- Upgrade/V5.hs | 2 +- Upgrade/V5/Direct.hs | 4 +- Upgrade/V7.hs | 9 ++-- Utility/Directory.hs | 16 +++---- Utility/LinuxMkLibs.hs | 2 +- Utility/LockFile/PidLock.hs | 70 +++++++++++++++++------------- Utility/LockFile/Posix.hs | 7 ++- Utility/LockFile/Windows.hs | 11 +++-- Utility/LockPool/STM.hs | 3 +- Utility/RawFilePath.hs | 10 +++++ 51 files changed, 182 insertions(+), 153 deletions(-) diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs index cbb4a33f13..c542e6b88b 100644 --- a/Annex/AutoMerge.hs +++ b/Annex/AutoMerge.hs @@ -176,7 +176,7 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do -- files, so delete here. unless inoverlay $ unless (islocked LsFiles.valUs) $ - liftIO $ nukeFile file + liftIO $ removeWhenExistsWith removeLink file | otherwise -> do -- Only resolve using symlink when both -- were locked, otherwise use unlocked @@ -309,7 +309,7 @@ cleanConflictCruft resolvedks resolvedfs unstagedmap = do <$> mapM Database.Keys.getInodeCaches resolvedks forM_ (M.toList unstagedmap) $ \(i, f) -> whenM (matchesresolved is i f) $ - liftIO $ nukeFile f + liftIO $ removeWhenExistsWith removeLink f where fs = S.fromList resolvedfs ks = S.fromList resolvedks diff --git a/Annex/Branch.hs b/Annex/Branch.hs index 072fd44b9e..a942e51e7b 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -533,7 +533,7 @@ stageJournal jl commitindex = withIndex $ withOtherTmp $ \tmpdir -> do stagedfs <- lines <$> hGetContents jlogh mapM_ (removeFile . (dir )) stagedfs hClose jlogh - nukeFile jlogf + removeWhenExistsWith removeLink jlogf openjlog tmpdir = liftIO $ openTempFile tmpdir "jlog" {- This is run after the refs have been merged into the index, diff --git a/Annex/Content.hs b/Annex/Content.hs index f3e7dad450..85aa2ef77f 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -171,7 +171,7 @@ inAnnexSafe key = Nothing -> return is_locked Just lockhandle -> do dropLock lockhandle - void $ tryIO $ nukeFile lockfile + void $ tryIO $ removeWhenExistsWith removeLink lockfile return is_unlocked , return is_missing ) @@ -295,7 +295,7 @@ lockContentUsing locker key fallback a = do cleanuplockfile lockfile = modifyContent lockfile $ void $ liftIO $ tryIO $ - nukeFile lockfile + removeWhenExistsWith removeLink lockfile {- Runs an action, passing it the temp file to get, - and if the action succeeds, verifies the file matches @@ -338,7 +338,7 @@ getViaTmpFromDisk rsp v key action = checkallowed $ do -- including perhaps the content of another -- file than the one that was requested, -- and so it's best not to keep it on disk. - pruneTmpWorkDirBefore tmpfile (liftIO . nukeFile) + pruneTmpWorkDirBefore tmpfile (liftIO . removeWhenExistsWith removeLink) return False ) -- On transfer failure, the tmp file is left behind, in case @@ -460,7 +460,7 @@ withTmp :: Key -> (FilePath -> Annex a) -> Annex a withTmp key action = do tmp <- prepTmp key res <- action tmp - pruneTmpWorkDirBefore tmp (liftIO . nukeFile) + pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith removeLink) return res {- Moves a key's content into .git/annex/objects/ @@ -595,16 +595,16 @@ linkAnnex fromto key src (Just srcic) dest destmode = catMaybes [destic, Just srcic] return LinkAnnexOk _ -> do - liftIO $ nukeFile dest + liftIO $ removeWhenExistsWith removeLink dest failed {- Removes the annex object file for a key. Lowlevel. -} unlinkAnnex :: Key -> Annex () unlinkAnnex key = do - obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) + obj <- calcRepo (gitAnnexLocation key) modifyContent obj $ do secureErase obj - liftIO $ nukeFile obj + liftIO $ removeWhenExistsWith R.removeLink obj {- Runs an action to transfer an object's content. - @@ -674,7 +674,7 @@ removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file -> cleanObjectLoc key $ do let file' = fromRawFilePath file secureErase file' - liftIO $ nukeFile file' + liftIO $ removeWhenExistsWith removeLink file' g <- Annex.gitRepo mapM_ (\f -> void $ tryIO $ resetpointer $ fromTopFilePath f g) =<< Database.Keys.getAssociatedFiles key diff --git a/Annex/Content/PointerFile.hs b/Annex/Content/PointerFile.hs index 91a982014f..47cf773ffe 100644 --- a/Annex/Content/PointerFile.hs +++ b/Annex/Content/PointerFile.hs @@ -25,6 +25,7 @@ import Utility.InodeCache #if ! defined(mingw32_HOST_OS) import Utility.Touch #endif +import qualified Utility.RawFilePath as R {- Populates a pointer file with the content of a key. - @@ -37,8 +38,8 @@ populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f) where go (Just k') | k == k' = do let f' = fromRawFilePath f - destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f' - liftIO $ nukeFile f' + destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus f + liftIO $ removeWhenExistsWith R.removeLink f (ic, populated) <- replaceWorkTreeFile f' $ \tmp -> do let tmp' = toRawFilePath tmp ok <- linkOrCopy k (fromRawFilePath obj) tmp destmode >>= \case @@ -61,7 +62,7 @@ depopulatePointerFile key file = do st <- liftIO $ catchMaybeIO $ getFileStatus file' let mode = fmap fileMode st secureErase file' - liftIO $ nukeFile file' + liftIO $ removeWhenExistsWith R.removeLink file ic <- replaceWorkTreeFile file' $ \tmp -> do liftIO $ writePointerFile (toRawFilePath tmp) key mode #if ! defined(mingw32_HOST_OS) diff --git a/Annex/Fixup.hs b/Annex/Fixup.hs index d8f892a989..37cbe8f63a 100644 --- a/Annex/Fixup.hs +++ b/Annex/Fixup.hs @@ -109,11 +109,10 @@ fixupUnusualRepos r@(Repo { location = l@(Local { worktree = Just w, gitdir = d ) where dotgit = w ".git" - dotgit' = fromRawFilePath dotgit - replacedotgit = whenM (doesFileExist dotgit') $ do + replacedotgit = whenM (doesFileExist (fromRawFilePath dotgit)) $ do linktarget <- relPathDirToFile w d - nukeFile dotgit' + removeWhenExistsWith R.removeLink dotgit R.createSymbolicLink linktarget dotgit unsetcoreworktree = diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs index bc6e5e2ae1..0d761199f4 100644 --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -112,7 +112,7 @@ lockDown' cfg file = tryIO $ ifM crippledFileSystem (tmpfile, h) <- openTempFile tmpdir $ relatedTemplate $ "ingest-" ++ takeFileName file hClose h - nukeFile tmpfile + removeWhenExistsWith removeLink tmpfile withhardlink' delta tmpfile `catchIO` const (nohardlink' delta) @@ -229,7 +229,7 @@ populateAssociatedFiles key source restage = do cleanCruft :: KeySource -> Annex () cleanCruft source = when (contentLocation source /= keyFilename source) $ - liftIO $ nukeFile $ fromRawFilePath $ contentLocation source + liftIO $ removeWhenExistsWith R.removeLink $ contentLocation source -- If a worktree file was was hard linked to an annex object before, -- modifying the file would have caused the object to have the wrong @@ -262,7 +262,7 @@ cleanOldKeys file newkey = do restoreFile :: FilePath -> Key -> SomeException -> Annex a restoreFile file key e = do whenM (inAnnex key) $ do - liftIO $ nukeFile file + liftIO $ removeWhenExistsWith removeLink file -- The key could be used by other files too, so leave the -- content in the annex, and make a copy back to the file. obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) diff --git a/Annex/Init.hs b/Annex/Init.hs index ac640fcf6e..2a144e8ef1 100644 --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -208,9 +208,9 @@ probeCrippledFileSystem' tmp = do where probe f = catchDefaultIO (True, []) $ do let f2 = f ++ "2" - nukeFile f2 + removeWhenExistsWith removeLink f2 createSymbolicLink f f2 - nukeFile f2 + removeWhenExistsWith removeLink f2 preventWrite f -- Should be unable to write to the file, unless -- running as root, but some crippled @@ -251,13 +251,13 @@ probeLockSupport = withEventuallyCleanedOtherTmp $ \tmp -> do liftIO $ withAsync warnstall (const (go f mode)) where go f mode = do - nukeFile f + removeWhenExistsWith removeLink f let locktest = bracket (Posix.lockExclusive (Just mode) f) Posix.dropLock (const noop) ok <- isRight <$> tryNonAsync locktest - nukeFile f + removeWhenExistsWith removeLink f return ok warnstall = do @@ -275,14 +275,14 @@ probeFifoSupport = do let f = tmp "gaprobe" let f2 = tmp "gaprobe2" liftIO $ do - nukeFile f - nukeFile f2 + removeWhenExistsWith removeLink f + removeWhenExistsWith removeLink f2 ms <- tryIO $ do createNamedPipe f ownerReadMode createLink f f2 getFileStatus f - nukeFile f - nukeFile f2 + removeWhenExistsWith removeLink f + removeWhenExistsWith removeLink f2 return $ either (const False) isNamedPipe ms #endif diff --git a/Annex/Locations.hs b/Annex/Locations.hs index ec63b64069..7ccf619c97 100644 --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -505,12 +505,12 @@ gitAnnexIgnoredRefs :: Git.Repo -> FilePath gitAnnexIgnoredRefs r = fromRawFilePath $ gitAnnexDir r P. "ignoredrefs" {- Pid file for daemon mode. -} -gitAnnexPidFile :: Git.Repo -> FilePath -gitAnnexPidFile r = fromRawFilePath $ gitAnnexDir r P. "daemon.pid" +gitAnnexPidFile :: Git.Repo -> RawFilePath +gitAnnexPidFile r = gitAnnexDir r P. "daemon.pid" {- Pid lock file for pidlock mode -} -gitAnnexPidLockFile :: Git.Repo -> FilePath -gitAnnexPidLockFile r = fromRawFilePath $ gitAnnexDir r P. "pidlock" +gitAnnexPidLockFile :: Git.Repo -> RawFilePath +gitAnnexPidLockFile r = gitAnnexDir r P. "pidlock" {- Status file for daemon mode. -} gitAnnexDaemonStatusFile :: Git.Repo -> FilePath diff --git a/Annex/LockFile.hs b/Annex/LockFile.hs index dbef08bad2..ad3ef53296 100644 --- a/Annex/LockFile.hs +++ b/Annex/LockFile.hs @@ -30,7 +30,7 @@ import qualified System.FilePath.ByteString as P {- Create a specified lock file, and takes a shared lock, which is retained - in the cache. -} -lockFileCached :: FilePath -> Annex () +lockFileCached :: RawFilePath -> Annex () lockFileCached file = go =<< fromLockCache file where go (Just _) = noop -- already locked @@ -43,7 +43,7 @@ lockFileCached file = go =<< fromLockCache file #endif changeLockCache $ M.insert file lockhandle -unlockFile :: FilePath -> Annex () +unlockFile :: RawFilePath -> Annex () unlockFile file = maybe noop go =<< fromLockCache file where go lockhandle = do @@ -53,7 +53,7 @@ unlockFile file = maybe noop go =<< fromLockCache file getLockCache :: Annex LockCache getLockCache = getState lockcache -fromLockCache :: FilePath -> Annex (Maybe LockHandle) +fromLockCache :: RawFilePath -> Annex (Maybe LockHandle) fromLockCache file = M.lookup file <$> getLockCache changeLockCache :: (LockCache -> LockCache) -> Annex () @@ -68,7 +68,7 @@ withSharedLock getlockfile a = debugLocks $ do lockfile <- fromRepo getlockfile createAnnexDirectory $ P.takeDirectory lockfile mode <- annexFileMode - bracket (lock mode (fromRawFilePath lockfile)) (liftIO . dropLock) (const a) + bracket (lock mode lockfile) (liftIO . dropLock) (const a) where #ifndef mingw32_HOST_OS lock mode = noUmask mode . lockShared (Just mode) @@ -90,7 +90,7 @@ takeExclusiveLock getlockfile = debugLocks $ do lockfile <- fromRepo getlockfile createAnnexDirectory $ P.takeDirectory lockfile mode <- annexFileMode - lock mode (fromRawFilePath lockfile) + lock mode lockfile where #ifndef mingw32_HOST_OS lock mode = noUmask mode . lockExclusive (Just mode) @@ -105,7 +105,7 @@ tryExclusiveLock getlockfile a = debugLocks $ do lockfile <- fromRepo getlockfile createAnnexDirectory $ P.takeDirectory lockfile mode <- annexFileMode - bracket (lock mode (fromRawFilePath lockfile)) (liftIO . unlock) go + bracket (lock mode lockfile) (liftIO . unlock) go where #ifndef mingw32_HOST_OS lock mode = noUmask mode . tryLockExclusive (Just mode) diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index b19e54527e..6a6c33629d 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -333,7 +333,7 @@ forceStopSsh socketfile = withNullHandle $ \nullh -> do } void $ liftIO $ catchMaybeIO $ withCreateProcess p $ \_ _ _ pid -> forceSuccessProcess p pid - liftIO $ nukeFile socketfile + liftIO $ removeWhenExistsWith removeLink socketfile {- This needs to be as short as possible, due to limitations on the length - of the path to a socket file. At the same time, it needs to be unique diff --git a/Annex/Tmp.hs b/Annex/Tmp.hs index 1adc26d9a4..cb68e73598 100644 --- a/Annex/Tmp.hs +++ b/Annex/Tmp.hs @@ -67,5 +67,5 @@ cleanupOtherTmp = do let oldenough = now - (60 * 60 * 24 * 7) catchMaybeIO (modificationTime <$> getSymbolicLinkStatus f) >>= \case Just mtime | realToFrac mtime <= oldenough -> - void $ tryIO $ nukeFile f + void $ tryIO $ removeWhenExistsWith removeLink f _ -> return () diff --git a/Annex/View.hs b/Annex/View.hs index 725cce3cb6..d84f9d4ec1 100644 --- a/Annex/View.hs +++ b/Annex/View.hs @@ -353,7 +353,7 @@ applyView' :: MkViewedFile -> (FilePath -> MetaData) -> View -> Annex Git.Branch applyView' mkviewedfile getfilemetadata view = do top <- fromRepo Git.repoPath (l, clean) <- inRepo $ Git.LsFiles.inRepoDetails [] [top] - liftIO . nukeFile =<< fromRepo gitAnnexViewIndex + liftIO . removeWhenExistsWith removeLink =<< fromRepo gitAnnexViewIndex viewg <- withViewIndex gitRepo withUpdateIndex viewg $ \uh -> do forM_ l $ \(f, sha, mode) -> do diff --git a/Assistant/Repair.hs b/Assistant/Repair.hs index a96921796c..182c98b0e3 100644 --- a/Assistant/Repair.hs +++ b/Assistant/Repair.hs @@ -148,7 +148,7 @@ repairStaleLocks lockfiles = go =<< getsizes waitforit "to check stale git lock file" l' <- getsizes if l' == l - then liftIO $ mapM_ nukeFile (map fst l) + then liftIO $ mapM_ (removeWhenExistsWith removeLink . fst) l else go l' , do waitforit "for git lock file writer" diff --git a/Assistant/Restart.hs b/Assistant/Restart.hs index ec34c52181..10848080f1 100644 --- a/Assistant/Restart.hs +++ b/Assistant/Restart.hs @@ -39,8 +39,8 @@ import Network.URI prepRestart :: Assistant () prepRestart = do liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread - liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexUrlFile) - liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexPidFile) + liftIO . removeWhenExistsWith removeLink =<< liftAnnex (fromRepo gitAnnexUrlFile) + liftIO . removeWhenExistsWith removeLink =<< liftAnnex (fromRepo gitAnnexPidFile) {- To finish a restart, send a global redirect to the new url - to any web browsers that are displaying the webapp. diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index dc91eeca72..84c3d8a3b8 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -66,7 +66,7 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta ifM (not <$> liftAnnex (inRepo checkIndexFast)) ( do notice ["corrupt index file found at startup; removing and restaging"] - liftAnnex $ inRepo $ nukeFile . indexFile + liftAnnex $ inRepo $ removeWhenExistsWith removeLink . indexFile {- Normally the startup scan avoids re-staging files, - but with the index deleted, everything needs to be - restaged. -} @@ -80,7 +80,7 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta - will be automatically regenerated. -} unlessM (liftAnnex $ Annex.Branch.withIndex $ inRepo $ Git.Repair.checkIndexFast) $ do notice ["corrupt annex/index file found at startup; removing"] - liftAnnex $ liftIO . nukeFile =<< fromRepo gitAnnexIndex + liftAnnex $ liftIO . removeWhenExistsWith removeLink =<< fromRepo gitAnnexIndex {- Fix up ssh remotes set up by past versions of the assistant. -} liftIO $ fixUpSshRemotes diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs index 2e7d8d0bfb..9599766323 100644 --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -220,7 +220,7 @@ upgradeToDistribution newdir cleanup distributionfile = do error $ "did not find " ++ dir ++ " in " ++ distributionfile makeorigsymlink olddir = do let origdir = parentDir olddir installBase - nukeFile origdir + removeWhenExistsWith removeLink origdir createSymbolicLink newdir origdir {- Finds where the old version was installed. -} @@ -278,8 +278,8 @@ installBase = "git-annex." ++ deleteFromManifest :: FilePath -> IO () deleteFromManifest dir = do fs <- map (dir ) . lines <$> catchDefaultIO "" (readFile manifest) - mapM_ nukeFile fs - nukeFile manifest + mapM_ (removeWhenExistsWith removeLink) fs + removeWhenExistsWith removeLink manifest removeEmptyRecursive dir where manifest = dir "git-annex.MANIFEST" diff --git a/Build/DistributionUpdate.hs b/Build/DistributionUpdate.hs index 5e83d62600..e8b219c28e 100644 --- a/Build/DistributionUpdate.hs +++ b/Build/DistributionUpdate.hs @@ -83,10 +83,10 @@ getbuild repodir (url, f) = do bv1 <- getbv let dest = repodir f let tmp = dest ++ ".tmp" - nukeFile tmp + removeWhenExistsWith removeFile tmp createDirectoryIfMissing True (parentDir dest) let oops s = do - nukeFile tmp + removeWhenExistsWith removeFile tmp putStrLn $ "*** " ++ s return Nothing uo <- defUrlOptions @@ -98,7 +98,7 @@ getbuild repodir (url, f) = do Nothing -> oops $ "no build-version file for " ++ url (Just v) | bv2 == bv1 -> do - nukeFile dest + removeWhenExistsWith removeFile dest renameFile tmp dest -- remove git rev part of version let v' = takeWhile (/= '-') v @@ -228,7 +228,7 @@ buildrpms topdir l = do <$> liftIO (getDirectoryContents rpmrepo) forM_ tarrpmarches $ \(tararch, rpmarch) -> forM_ (filter (isstandalonetarball tararch . fst) l) $ \(tarball, v) -> do - liftIO $ mapM_ nukeFile (filter ((rpmarch ++ ".rpm") `isSuffixOf`) oldrpms) + liftIO $ mapM_ (removeWhenExistsWith removeLink) (filter ((rpmarch ++ ".rpm") `isSuffixOf`) oldrpms) void $ liftIO $ boolSystem script [ Param rpmarch , File tarball diff --git a/Build/LinuxMkLibs.hs b/Build/LinuxMkLibs.hs index 60af30f1a4..5f3c8e9dc7 100644 --- a/Build/LinuxMkLibs.hs +++ b/Build/LinuxMkLibs.hs @@ -99,8 +99,8 @@ installLinkerShim top linker exe = do ifM (isSymbolicLink <$> getSymbolicLinkStatus exe) ( do sl <- readSymbolicLink exe - nukeFile exe - nukeFile exedest + removeWhenExistsWith removeLink exe + removeWhenExistsWith removeLink exedest -- Assume that for a symlink, the destination -- will also be shimmed. let sl' = ".." takeFileName sl takeFileName sl diff --git a/Build/Standalone.hs b/Build/Standalone.hs index 15ac2f252a..f39322db59 100644 --- a/Build/Standalone.hs +++ b/Build/Standalone.hs @@ -95,7 +95,7 @@ installGitLibs topdir = do unlessM (doesFileExist linktarget') $ do createDirectoryIfMissing True (takeDirectory linktarget') L.readFile f >>= L.writeFile linktarget' - nukeFile destf + removeWhenExistsWith removeLink destf rellinktarget <- relPathDirToFile (takeDirectory destf) linktarget' createSymbolicLink rellinktarget destf else cp f destf @@ -125,7 +125,7 @@ installGitLibs topdir = do cp :: FilePath -> FilePath -> IO () cp src dest = do - nukeFile dest + removeWhenExistsWith removeLink dest unlessM (boolSystem "cp" [Param "-a", File src, File dest]) $ error "cp failed" diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 1c775a8cce..d39e9cd583 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -326,7 +326,7 @@ downloadWeb addunlockedmatcher o url urlinfo file = Left _ -> normalfinish tmp where dl dest = withTmpWorkDir mediakey $ \workdir -> do - let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . nukeFile) + let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith removeLink) showNote "using youtube-dl" Transfer.notifyTransfer Transfer.Download url $ Transfer.download webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \p -> @@ -446,7 +446,7 @@ addWorkTree _ addunlockedmatcher u url file key mtmp = case mtmp of ( do when (isJust mtmp) $ logStatus key InfoPresent - , maybe noop (\tmp -> pruneTmpWorkDirBefore tmp (liftIO . nukeFile)) mtmp + , maybe noop (\tmp -> pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith removeLink)) mtmp ) -- git does not need to check ignores, because that has already diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index a4d2fa68b4..f0415eaa90 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -66,5 +66,5 @@ perform from numcopies key = case from of performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform performOther filespec key = do f <- fromRepo $ filespec key - pruneTmpWorkDirBefore f (liftIO . nukeFile) + pruneTmpWorkDirBefore f (liftIO . removeWhenExistsWith removeLink) next $ return True diff --git a/Command/Fsck.hs b/Command/Fsck.hs index eb4295454e..7a9800694d 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -584,7 +584,7 @@ recordStartTime :: UUID -> Annex () recordStartTime u = do f <- fromRepo (gitAnnexFsckState u) createAnnexDirectory $ parentDir f - liftIO $ nukeFile f + liftIO $ removeWhenExistsWith removeLink f liftIO $ withFile f WriteMode $ \h -> do #ifndef mingw32_HOST_OS t <- modificationTime <$> getFileStatus f @@ -598,7 +598,8 @@ recordStartTime u = do showTime = show resetStartTime :: UUID -> Annex () -resetStartTime u = liftIO . nukeFile =<< fromRepo (gitAnnexFsckState u) +resetStartTime u = liftIO . removeWhenExistsWith removeLink + =<< fromRepo (gitAnnexFsckState u) {- Gets the incremental fsck start time. -} getStartTime :: UUID -> Annex (Maybe EpochTime) diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs index 0597484b69..c1c6d4cee1 100644 --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -177,7 +177,8 @@ runFuzzAction (FuzzAdd (FuzzFile f)) = do createWorkTreeDirectory (parentDir f) n <- liftIO (getStdRandom random :: IO Int) liftIO $ writeFile f $ show n ++ "\n" -runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $ nukeFile f +runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $ + removeWhenExistsWith removeLink f runFuzzAction (FuzzMove (FuzzFile src) (FuzzFile dest)) = liftIO $ rename src dest runFuzzAction (FuzzDeleteDir (FuzzDir d)) = liftIO $ diff --git a/Command/Import.hs b/Command/Import.hs index 18f75432e7..cbe6fd0ac7 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -175,13 +175,13 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) = | isDirectory s -> notoverwriting "(is a directory)" | isSymbolicLink s -> ifM (Annex.getState Annex.force) ( do - liftIO $ nukeFile destfile + liftIO $ removeWhenExistsWith removeLink destfile importfilechecked ld k , notoverwriting "(is a symlink)" ) | otherwise -> ifM (Annex.getState Annex.force) ( do - liftIO $ nukeFile destfile + liftIO $ removeWhenExistsWith removeLink destfile importfilechecked ld k , notoverwriting "(use --force to override, or a duplication option such as --deduplicate to clean up)" ) diff --git a/Command/Lock.hs b/Command/Lock.hs index 04037244f1..39798d8f1c 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -89,7 +89,7 @@ perform file key = do fs <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key mfile <- firstM (isUnmodified key) fs - liftIO $ nukeFile obj + liftIO $ removeWhenExistsWith removeLink obj case mfile of Just unmodified -> unlessM (checkedCopyFile key (fromRawFilePath unmodified) obj Nothing) diff --git a/Command/Multicast.hs b/Command/Multicast.hs index d90c114649..c4ef2ce23e 100644 --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -84,7 +84,7 @@ genAddress = starting "gen-address" (ActionItemOther Nothing) (SeekInput []) $ d KeyContainer s -> liftIO $ genkey (Param s) KeyFile f -> do createAnnexDirectory (takeDirectory f) - liftIO $ nukeFile f + liftIO $ removeWhenExistsWith removeLink f liftIO $ protectedOutput $ genkey (File f) case (ok, parseFingerprint s) of (False, _) -> giveup $ "uftp_keymgt failed: " ++ s @@ -210,7 +210,7 @@ storeReceived f = do case deserializeKey (takeFileName f) of Nothing -> do warning $ "Received a file " ++ f ++ " that is not a git-annex key. Deleting this file." - liftIO $ nukeFile f + liftIO $ removeWhenExistsWith removeLink f Just k -> void $ getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k $ \dest -> unVerified $ liftIO $ catchBoolIO $ do diff --git a/Command/P2P.hs b/Command/P2P.hs index 72ee857be8..f503878aaa 100644 --- a/Command/P2P.hs +++ b/Command/P2P.hs @@ -256,7 +256,7 @@ wormholePairing remotename ouraddrs ui = do Wormhole.sendFile sendf observer wormholeparams `concurrently` Wormhole.receiveFile recvf producer wormholeparams - liftIO $ nukeFile sendf + liftIO $ removeWhenExistsWith removeLink sendf if sendres /= True then return SendFailed else if recvres /= True diff --git a/Command/Repair.hs b/Command/Repair.hs index bcd5730c02..eed3fcb03b 100644 --- a/Command/Repair.hs +++ b/Command/Repair.hs @@ -75,7 +75,7 @@ repairAnnexBranch modifiedbranches Annex.Branch.forceCommit "committing index after git repository repair" liftIO $ putStrLn "Successfully recovered the git-annex branch using .git/annex/index" nukeindex = do - inRepo $ nukeFile . gitAnnexIndex + inRepo $ removeWhenExistsWith removeLink . gitAnnexIndex liftIO $ putStrLn "Had to delete the .git/annex/index file as it was corrupt." missingbranch = liftIO $ putStrLn "Since the git-annex branch is not up-to-date anymore. It would be a very good idea to run: git annex fsck --fast" diff --git a/Command/Undo.hs b/Command/Undo.hs index 063b0d604c..c587997a2b 100644 --- a/Command/Undo.hs +++ b/Command/Undo.hs @@ -67,7 +67,7 @@ perform p = do forM_ removals $ \di -> do f <- mkrel di - liftIO $ nukeFile f + liftIO $ removeWhenExistsWith removeLink f forM_ adds $ \di -> do f <- mkrel di diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs index c031c5a24b..a9959c0a8e 100644 --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -57,7 +57,7 @@ vicfg curcfg f = do unlessM (liftIO $ boolSystem "sh" [Param "-c", Param $ unwords [vi, shellEscape f]]) $ giveup $ vi ++ " exited nonzero; aborting" r <- parseCfg (defCfg curcfg) <$> liftIO (readFileStrict f) - liftIO $ nukeFile f + liftIO $ removeWhenExistsWith removeLink f case r of Left s -> do liftIO $ writeFile f s diff --git a/Config.hs b/Config.hs index 62126bedd9..5dd65cdff3 100644 --- a/Config.hs +++ b/Config.hs @@ -85,7 +85,7 @@ setCrippledFileSystem :: Bool -> Annex () setCrippledFileSystem b = setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b) -pidLockFile :: Annex (Maybe FilePath) +pidLockFile :: Annex (Maybe RawFilePath) #ifndef mingw32_HOST_OS pidLockFile = ifM (annexPidLock <$> Annex.getGitConfig) ( Just <$> Annex.fromRepo gitAnnexPidLockFile diff --git a/Creds.hs b/Creds.hs index af7240c002..6ab3b81925 100644 --- a/Creds.hs +++ b/Creds.hs @@ -212,7 +212,7 @@ removeCreds :: FilePath -> Annex () removeCreds file = do d <- fromRawFilePath <$> fromRepo gitAnnexCredsDir let f = d file - liftIO $ nukeFile f + liftIO $ removeWhenExistsWith removeLink f includeCredsInfo :: ParsedRemoteConfig -> CredPairStorage -> [(String, String)] -> Annex [(String, String)] includeCredsInfo pc@(ParsedRemoteConfig cm _) storage info = do diff --git a/Git/Repair.hs b/Git/Repair.hs index ff2c2dc225..eb8736a011 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -39,6 +39,7 @@ import Utility.Directory.Create import Utility.Tmp.Dir import Utility.Rsync import Utility.FileMode +import qualified Utility.RawFilePath as R import qualified Data.Set as S import qualified Data.ByteString.Lazy as L @@ -52,7 +53,7 @@ cleanCorruptObjects fsckresults r = do mapM_ removeLoose (S.toList $ knownMissing fsckresults) mapM_ removeBad =<< listLooseObjectShas r where - removeLoose s = nukeFile (looseObjectFile r s) + removeLoose s = removeWhenExistsWith removeLink (looseObjectFile r s) removeBad s = do void $ tryIO $ allowRead $ looseObjectFile r s whenM (isMissing s r) $ @@ -78,7 +79,7 @@ explodePacks r = go =<< listPackFiles r putStrLn "Unpacking all pack files." forM_ packs $ \packfile -> do moveFile packfile (tmpdir takeFileName packfile) - nukeFile $ packIdxFile packfile + removeWhenExistsWith removeLink $ packIdxFile packfile forM_ packs $ \packfile -> do let tmp = tmpdir takeFileName packfile allowRead tmp @@ -245,7 +246,7 @@ explodePackedRefsFile r = do rs <- mapMaybe parsePacked . lines <$> catchDefaultIO "" (safeReadFile f) forM_ rs makeref - nukeFile f + removeWhenExistsWith removeLink f where makeref (sha, ref) = do let gitd = localGitDir r @@ -268,7 +269,7 @@ parsePacked l = case words l of {- git-branch -d cannot be used to remove a branch that is directly - pointing to a corrupt commit. -} nukeBranchRef :: Branch -> Repo -> IO () -nukeBranchRef b r = nukeFile $ fromRawFilePath (localGitDir r) fromRef b +nukeBranchRef b r = removeWhenExistsWith R.removeLink $ localGitDir r P. fromRef' b {- Finds the most recent commit to a branch that does not need any - of the missing objects. If the input branch is good as-is, returns it. @@ -394,7 +395,7 @@ rewriteIndex r | otherwise = do (bad, good, cleanup) <- partitionIndex r unless (null bad) $ do - nukeFile (indexFile r) + removeWhenExistsWith removeLink (indexFile r) UpdateIndex.streamUpdateIndex r =<< (catMaybes <$> mapM reinject good) void cleanup @@ -442,7 +443,7 @@ displayList items header preRepair :: Repo -> IO () preRepair g = do unlessM (validhead <$> catchDefaultIO "" (safeReadFile headfile)) $ do - nukeFile headfile + removeWhenExistsWith removeLink headfile writeFile headfile "ref: refs/heads/master" explodePackedRefsFile g unless (repoIsLocalBare g) $ do @@ -571,7 +572,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do else successfulfinish modifiedbranches corruptedindex = do - nukeFile (indexFile g) + removeWhenExistsWith removeLink (indexFile g) -- The corrupted index can prevent fsck from finding other -- problems, so re-run repair. fsckresult' <- findBroken False g diff --git a/Logs/FsckResults.hs b/Logs/FsckResults.hs index 1f188ed08f..ee861704c2 100644 --- a/Logs/FsckResults.hs +++ b/Logs/FsckResults.hs @@ -24,7 +24,7 @@ writeFsckResults u fsckresults = do case fsckresults of FsckFailed -> store S.empty False logfile FsckFoundMissing s t - | S.null s -> liftIO $ nukeFile logfile + | S.null s -> liftIO $ removeWhenExistsWith removeLink logfile | otherwise -> store s t logfile where store s t logfile = writeLogFile logfile $ serialize s t @@ -47,5 +47,6 @@ readFsckResults u = do in if S.null s then FsckFailed else FsckFoundMissing s t clearFsckResults :: UUID -> Annex () -clearFsckResults = liftIO . nukeFile <=< fromRepo . gitAnnexFsckResultsLog +clearFsckResults = liftIO . removeWhenExistsWith removeLink + <=< fromRepo . gitAnnexFsckResultsLog diff --git a/P2P/IO.hs b/P2P/IO.hs index 9a73f1e113..43075546bc 100644 --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -124,7 +124,7 @@ closeConnection conn = do -- the callback. serveUnixSocket :: FilePath -> (Handle -> IO ()) -> IO () serveUnixSocket unixsocket serveconn = do - nukeFile unixsocket + removeWhenExistsWith removeLink unixsocket soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol S.bind soc (S.SockAddrUnix unixsocket) -- Allow everyone to read and write to the socket, diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs index 7d787c13d0..91f0253418 100644 --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -179,7 +179,7 @@ tmpTorrentFile u = fromRepo . gitAnnexTmpObjectLocation =<< torrentUrlKey u -} registerTorrentCleanup :: URLString -> Annex () registerTorrentCleanup u = Annex.addCleanup (TorrentCleanup u) $ - liftIO . nukeFile =<< tmpTorrentFile u + liftIO . removeWhenExistsWith removeLink =<< tmpTorrentFile u {- Downloads the torrent file. (Not its contents.) -} downloadTorrentFile :: URLString -> Annex Bool diff --git a/Remote/Directory.hs b/Remote/Directory.hs index a4a2c6ccd6..99ea5a1025 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -284,7 +284,7 @@ retrieveExportM d _k loc dest p = removeExportM :: FilePath -> Key -> ExportLocation -> Annex () removeExportM d _k loc = liftIO $ do - nukeFile src + removeWhenExistsWith removeLink src removeExportLocation d loc where src = exportPath d loc diff --git a/Remote/Directory/LegacyChunked.hs b/Remote/Directory/LegacyChunked.hs index 5719ebe8e3..61b3e2d17e 100644 --- a/Remote/Directory/LegacyChunked.hs +++ b/Remote/Directory/LegacyChunked.hs @@ -98,7 +98,7 @@ retrieve locations d basek p c = withOtherTmp $ \tmpdir -> do S.appendFile tmp <=< S.readFile return True b <- liftIO $ L.readFile tmp - liftIO $ nukeFile tmp + liftIO $ removeWhenExistsWith removeLink tmp sink b byteRetriever go basek p c diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index 18d09880a6..7de1b498f2 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -283,10 +283,10 @@ sink dest enc c mh mp content = case (enc, mh, content) of withBytes content $ \b -> decrypt cmd c cipher (feedBytes b) $ readBytes write - liftIO $ nukeFile f + liftIO $ removeWhenExistsWith removeLink f (Nothing, _, FileContent f) -> do withBytes content write - liftIO $ nukeFile f + liftIO $ removeWhenExistsWith removeLink f (Nothing, _, ByteContent b) -> write b where write b = case mh of diff --git a/Test.hs b/Test.hs index 677303bc59..813a632b4d 100644 --- a/Test.hs +++ b/Test.hs @@ -409,7 +409,7 @@ test_ignore_deleted_files :: Assertion test_ignore_deleted_files = intmpclonerepo $ do git_annex "get" [annexedfile] @? "get failed" git_annex_expectoutput "find" [] [annexedfile] - nukeFile annexedfile + removeWhenExistsWith removeLink annexedfile -- A file that has been deleted, but the deletion not staged, -- is a special case; make sure git-annex skips these. git_annex_expectoutput "find" [] [] @@ -759,7 +759,8 @@ test_lock_force = intmpclonerepo $ do Just k <- Annex.WorkTree.lookupKey (toRawFilePath annexedfile) Database.Keys.removeInodeCaches k Database.Keys.closeDb - liftIO . nukeFile =<< Annex.fromRepo Annex.Locations.gitAnnexKeysDbIndexCache + liftIO . removeWhenExistsWith removeLink + =<< Annex.fromRepo Annex.Locations.gitAnnexKeysDbIndexCache writecontent annexedfile "test_lock_force content" git_annex_shouldfail "lock" [annexedfile] @? "lock of modified file failed to fail" git_annex "lock" ["--force", annexedfile] @? "lock --force of modified file failed" @@ -1306,7 +1307,7 @@ test_remove_conflict_resolution = do @? "unlock conflictor failed" writecontent conflictor "newconflictor" indir r1 $ - nukeFile conflictor + removeWhenExistsWith removeLink conflictor let l = if inr1 then [r1, r2, r1] else [r2, r1, r2] forM_ l $ \r -> indir r $ git_annex "sync" [] @? "sync failed" @@ -1833,7 +1834,7 @@ test_export_import = intmpclonerepo $ do git_annex "merge" ["foo/" ++ origbranch] @? "git annex merge failed" annexed_present_imported "import" - nukeFile "import" + removeWhenExistsWith removeLink "import" writecontent "import" (content "newimport1") git_annex "add" ["import"] @? "add of import failed" commitchanges @@ -1842,7 +1843,7 @@ test_export_import = intmpclonerepo $ do -- verify that export refuses to overwrite modified file writedir "import" (content "newimport2") - nukeFile "import" + removeWhenExistsWith removeLink "import" writecontent "import" (content "newimport3") git_annex "add" ["import"] @? "add of import failed" commitchanges @@ -1852,7 +1853,7 @@ test_export_import = intmpclonerepo $ do -- resolving import conflict git_annex "import" [origbranch, "--from", "foo"] @? "import from dir failed" not <$> boolSystem "git" [Param "merge", Param "foo/master", Param "-mmerge"] @? "git merge of conflict failed to exit nonzero" - nukeFile "import" + removeWhenExistsWith removeLink "import" writecontent "import" (content "newimport3") git_annex "add" ["import"] @? "add of import failed" commitchanges diff --git a/Types/LockCache.hs b/Types/LockCache.hs index 668d603b13..5b921be17d 100644 --- a/Types/LockCache.hs +++ b/Types/LockCache.hs @@ -10,7 +10,9 @@ module Types.LockCache ( LockHandle ) where -import qualified Data.Map as M import Utility.LockPool (LockHandle) -type LockCache = M.Map FilePath LockHandle +import qualified Data.Map as M +import System.FilePath.ByteString (RawFilePath) + +type LockCache = M.Map RawFilePath LockHandle diff --git a/Upgrade/V5.hs b/Upgrade/V5.hs index 3e8dedaef9..7bfe0078aa 100644 --- a/Upgrade/V5.hs +++ b/Upgrade/V5.hs @@ -150,7 +150,7 @@ upgradeDirectWorkTree = do ) writepointer f k = liftIO $ do - nukeFile f + removeWhenExistsWith removeLink f S.writeFile f (formatPointer k) {- Remove all direct mode bookkeeping files. -} diff --git a/Upgrade/V5/Direct.hs b/Upgrade/V5/Direct.hs index 9af32e79ce..6fcc98be7a 100644 --- a/Upgrade/V5/Direct.hs +++ b/Upgrade/V5/Direct.hs @@ -96,7 +96,7 @@ removeAssociatedFiles :: Key -> Annex () removeAssociatedFiles key = do mapping <- calcRepo $ gitAnnexMapping key modifyContent mapping $ - liftIO $ nukeFile mapping + liftIO $ removeWhenExistsWith removeLink mapping {- Checks if a file in the tree, associated with a key, has not been modified. - @@ -122,7 +122,7 @@ recordedInodeCache key = withInodeCacheFile key $ \f -> removeInodeCache :: Key -> Annex () removeInodeCache key = withInodeCacheFile key $ \f -> modifyContent f $ - liftIO $ nukeFile f + liftIO $ removeWhenExistsWith removeLink f withInodeCacheFile :: Key -> (FilePath -> Annex a) -> Annex a withInodeCacheFile key a = a =<< calcRepo (gitAnnexInodeCache key) diff --git a/Upgrade/V7.hs b/Upgrade/V7.hs index 89bb78c4ad..097330006f 100644 --- a/Upgrade/V7.hs +++ b/Upgrade/V7.hs @@ -33,7 +33,8 @@ upgrade automatic = do -- new database is not populated. It will be automatically -- populated from the git-annex branch the next time it is used. removeOldDb gitAnnexContentIdentifierDbDirOld - liftIO . nukeFile =<< fromRepo gitAnnexContentIdentifierLockOld + liftIO . removeWhenExistsWith removeLink + =<< fromRepo gitAnnexContentIdentifierLockOld -- The export databases are deleted here. The new databases -- will be populated by the next thing that needs them, the same @@ -42,8 +43,10 @@ upgrade automatic = do populateKeysDb removeOldDb gitAnnexKeysDbOld - liftIO . nukeFile =<< fromRepo gitAnnexKeysDbIndexCacheOld - liftIO . nukeFile =<< fromRepo gitAnnexKeysDbLockOld + liftIO . removeWhenExistsWith removeLink + =<< fromRepo gitAnnexKeysDbIndexCacheOld + liftIO . removeWhenExistsWith removeLink + =<< fromRepo gitAnnexKeysDbLockOld updateSmudgeFilter diff --git a/Utility/Directory.hs b/Utility/Directory.hs index aef1aa2798..b839352e24 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -142,15 +142,9 @@ moveFile src dest = tryIO (rename src dest) >>= onrename (Right s) -> return $ isDirectory s #endif -{- Removes a file (or symlink), which may or may not exist. +{- Use with an action that removes something, which may or may not exist. - - - Note that an exception is thrown if the file exists but - - cannot be removed, or if its a directory. -} -nukeFile :: FilePath -> IO () -nukeFile file = void $ tryWhenExists go - where -#ifndef mingw32_HOST_OS - go = removeLink file -#else - go = removeFile file -#endif + - If an exception is thrown due to it not existing, it is ignored. + -} +removeWhenExistsWith :: (a -> IO ()) -> a -> IO () +removeWhenExistsWith f a = void $ tryWhenExists $ f a diff --git a/Utility/LinuxMkLibs.hs b/Utility/LinuxMkLibs.hs index f2e8adeaf5..72b7a3bb9e 100644 --- a/Utility/LinuxMkLibs.hs +++ b/Utility/LinuxMkLibs.hs @@ -48,7 +48,7 @@ installLib installfile top lib = ifM (doesFileExist lib) (toRawFilePath l) target <- relPathDirToFile (toRawFilePath (takeDirectory f)) absl installfile top (fromRawFilePath absl) - nukeFile (top ++ f) + removeWhenExistsWith removeLink (top ++ f) createSymbolicLink (fromRawFilePath target) (inTop top f) checksymlink (fromRawFilePath absl) diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs index 4c2b3a7154..521422d16b 100644 --- a/Utility/LockFile/PidLock.hs +++ b/Utility/LockFile/PidLock.hs @@ -5,6 +5,8 @@ - License: BSD-2-clause -} +{-# LANGUAGE OverloadedStrings #-} + module Utility.LockFile.PidLock ( LockHandle, tryLock, @@ -34,12 +36,13 @@ import Utility.Env.Set import qualified Utility.LockFile.Posix as Posix import System.IO -import System.Posix.IO import System.Posix.Types -import System.Posix.Files +import System.Posix.IO.ByteString +import System.Posix.Files.ByteString import System.Posix.Process import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO) +import qualified System.FilePath.ByteString as P import Data.Maybe import Data.List import Network.BSD @@ -47,7 +50,7 @@ import System.FilePath import Control.Applicative import Prelude -type LockFile = FilePath +type LockFile = RawFilePath data LockHandle = LockHandle LockFile FileStatus SideLockHandle @@ -67,7 +70,8 @@ mkPidLock = PidLock <*> getHostName readPidLock :: LockFile -> IO (Maybe PidLock) -readPidLock lockfile = (readish =<<) <$> catchMaybeIO (readFile lockfile) +readPidLock lockfile = (readish =<<) + <$> catchMaybeIO (readFile (fromRawFilePath lockfile)) -- To avoid races when taking over a stale pid lock, a side lock is used. -- This is a regular posix exclusive lock. @@ -100,7 +104,7 @@ dropSideLock (Just (f, h)) = do -- to take the side lock will only succeed once the file is -- deleted, and so will be able to immediately see that it's taken -- a stale lock. - _ <- tryIO $ removeFile f + _ <- tryIO $ removeFile (fromRawFilePath f) Posix.dropLock h -- The side lock is put in /dev/shm. This will work on most any @@ -108,17 +112,17 @@ dropSideLock (Just (f, h)) = do -- locks. /tmp is used as a fallback. sideLockFile :: LockFile -> IO LockFile sideLockFile lockfile = do - f <- fromRawFilePath <$> absPath (toRawFilePath lockfile) + f <- fromRawFilePath <$> absPath lockfile let base = intercalate "_" (splitDirectories (makeRelative "/" f)) let shortbase = reverse $ take 32 $ reverse base let md5sum = if base == shortbase then "" - else show (md5 (encodeBL base)) + else toRawFilePath $ show (md5 (encodeBL base)) dir <- ifM (doesDirectoryExist "/dev/shm") ( return "/dev/shm" , return "/tmp" ) - return $ dir md5sum ++ shortbase ++ ".lck" + return $ dir P. md5sum <> toRawFilePath shortbase <> ".lck" -- | Tries to take a lock; does not block when the lock is already held. -- @@ -131,25 +135,27 @@ sideLockFile lockfile = do -- "PIDLOCK_lockfile" environment variable, does not block either. tryLock :: LockFile -> IO (Maybe LockHandle) tryLock lockfile = do - abslockfile <- fromRawFilePath <$> absPath (toRawFilePath lockfile) + abslockfile <- absPath lockfile lockenv <- pidLockEnv abslockfile getEnv lockenv >>= \case Nothing -> trySideLock lockfile (go abslockfile) _ -> return (Just ParentLocked) where go abslockfile sidelock = do - (tmp, h) <- openTempFile (takeDirectory abslockfile) "locktmp" - setFileMode tmp (combineModes readModes) + let abslockfile' = fromRawFilePath abslockfile + (tmp, h) <- openTempFile (takeDirectory abslockfile') "locktmp" + let tmp' = toRawFilePath tmp + setFileMode tmp' (combineModes readModes) hPutStr h . show =<< mkPidLock hClose h let failedlock st = do - dropLock $ LockHandle tmp st sidelock - nukeFile tmp + dropLock $ LockHandle tmp' st sidelock + removeWhenExistsWith removeLink tmp' return Nothing let tooklock st = return $ Just $ LockHandle abslockfile st sidelock - ifM (linkToLock sidelock tmp abslockfile) + ifM (linkToLock sidelock tmp' abslockfile) ( do - nukeFile tmp + removeWhenExistsWith removeLink tmp' -- May not have made a hard link, so stat -- the lockfile lckst <- getFileStatus abslockfile @@ -157,7 +163,7 @@ tryLock lockfile = do , do v <- readPidLock abslockfile hn <- getHostName - tmpst <- getFileStatus tmp + tmpst <- getFileStatus tmp' case v of Just pl | isJust sidelock && hn == lockingHost pl -> do -- Since we have the sidelock, @@ -165,7 +171,7 @@ tryLock lockfile = do -- the pidlock was taken on, -- we know that the pidlock is -- stale, and can take it over. - rename tmp abslockfile + rename tmp' abslockfile tooklock tmpst _ -> failedlock tmpst ) @@ -180,12 +186,12 @@ tryLock lockfile = do -- -- However, not all filesystems support hard links. So, first probe -- to see if they are supported. If not, use open with O_EXCL. -linkToLock :: SideLockHandle -> FilePath -> FilePath -> IO Bool +linkToLock :: SideLockHandle -> RawFilePath -> RawFilePath -> IO Bool linkToLock Nothing _ _ = return False linkToLock (Just _) src dest = do - let probe = src ++ ".lnk" + let probe = src <> ".lnk" v <- tryIO $ createLink src probe - nukeFile probe + removeWhenExistsWith removeLink probe case v of Right _ -> do _ <- tryIO $ createLink src dest @@ -200,7 +206,8 @@ linkToLock (Just _) src dest = do (defaultFileFlags {exclusive = True}) fdToHandle fd let cleanup = hClose - bracket setup cleanup (\h -> readFile src >>= hPutStr h) + let go h = readFile (fromRawFilePath src) >>= hPutStr h + bracket setup cleanup go return True where checklinked = do @@ -228,16 +235,17 @@ linkToLock (Just _) src dest = do -- We can detect this insanity by getting the directory contents after -- making the link, and checking to see if 2 copies of the dest file, -- with the SAME FILENAME exist. -checkInsaneLustre :: FilePath -> IO Bool +checkInsaneLustre :: RawFilePath -> IO Bool checkInsaneLustre dest = do - fs <- dirContents (takeDirectory dest) - case length (filter (== dest) fs) of + let dest' = fromRawFilePath dest + fs <- dirContents (takeDirectory dest') + case length (filter (== dest') fs) of 1 -> return False -- whew! 0 -> return True -- wtf? _ -> do -- Try to clean up the extra copy we made -- that has the same name. Egads. - _ <- tryIO $ removeFile dest + _ <- tryIO $ removeFile dest' return True -- | Waits as necessary to take a lock. @@ -253,20 +261,20 @@ waitLock (Seconds timeout) lockfile displaymessage = go timeout | n > 0 = liftIO (tryLock lockfile) >>= \case Nothing -> do when (n == pred timeout) $ - displaymessage $ "waiting for pid lock file " ++ lockfile ++ " which is held by another process (or may be stale)" + displaymessage $ "waiting for pid lock file " ++ fromRawFilePath lockfile ++ " which is held by another process (or may be stale)" liftIO $ threadDelaySeconds (Seconds 1) go (pred n) Just lckh -> return lckh | otherwise = do - displaymessage $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ lockfile - giveup $ "Gave up waiting for pid lock file " ++ lockfile + displaymessage $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ fromRawFilePath lockfile + giveup $ "Gave up waiting for pid lock file " ++ fromRawFilePath lockfile dropLock :: LockHandle -> IO () dropLock (LockHandle lockfile _ sidelock) = do -- Drop side lock first, at which point the pid lock will be -- considered stale. dropSideLock sidelock - nukeFile lockfile + removeWhenExistsWith removeLink lockfile dropLock ParentLocked = return () getLockStatus :: LockFile -> IO LockStatus @@ -297,9 +305,9 @@ checkSaneLock _ ParentLocked = return True -- The parent process should keep running as long as the child -- process is running, since the child inherits the environment and will -- not see unsetLockEnv. -pidLockEnv :: FilePath -> IO String +pidLockEnv :: RawFilePath -> IO String pidLockEnv lockfile = do - abslockfile <- fromRawFilePath <$> absPath (toRawFilePath lockfile) + abslockfile <- fromRawFilePath <$> absPath lockfile return $ "PIDLOCK_" ++ filter legalInEnvVar abslockfile pidLockEnvValue :: String diff --git a/Utility/LockFile/Posix.hs b/Utility/LockFile/Posix.hs index 011d8f953b..b07c4fc142 100644 --- a/Utility/LockFile/Posix.hs +++ b/Utility/LockFile/Posix.hs @@ -25,10 +25,13 @@ import Utility.Applicative import Utility.LockFile.LockStatus import System.IO -import System.Posix +import System.Posix.Types +import System.Posix.IO.ByteString +import System.Posix.Files.ByteString +import System.FilePath.ByteString (RawFilePath) import Data.Maybe -type LockFile = FilePath +type LockFile = RawFilePath newtype LockHandle = LockHandle Fd diff --git a/Utility/LockFile/Windows.hs b/Utility/LockFile/Windows.hs index e761573544..a8a0748434 100644 --- a/Utility/LockFile/Windows.hs +++ b/Utility/LockFile/Windows.hs @@ -16,15 +16,18 @@ module Utility.LockFile.Windows ( import System.Win32.Types import System.Win32.File import Control.Concurrent +import System.FilePath.ByteString (RawFilePath) -type LockFile = FilePath +import Utility.FileSystemEncoding + +type LockFile = RawFilePath type LockHandle = HANDLE {- Tries to lock a file with a shared lock, which allows other processes to - also lock it shared. Fails if the file is exclusively locked. -} lockShared :: LockFile -> IO (Maybe LockHandle) -lockShared = openLock fILE_SHARE_READ +lockShared = openLock fILE_SHARE_READ . fromRawFilePath {- Tries to take an exclusive lock on a file. Fails if another process has - a shared or exclusive lock. @@ -33,7 +36,7 @@ lockShared = openLock fILE_SHARE_READ - read or write by any other process. So for advisory locking of a file's - content, a separate LockFile should be used. -} lockExclusive :: LockFile -> IO (Maybe LockHandle) -lockExclusive = openLock fILE_SHARE_NONE +lockExclusive = openLock fILE_SHARE_NONE . fromRawFilePath {- Windows considers just opening a file enough to lock it. This will - create the LockFile if it does not already exist. @@ -51,7 +54,7 @@ lockExclusive = openLock fILE_SHARE_NONE -} openLock :: ShareMode -> LockFile -> IO (Maybe LockHandle) openLock sharemode f = do - h <- withTString f $ \c_f -> + h <- withTString (fromRawFilePath f) $ \c_f -> c_CreateFile c_f gENERIC_READ sharemode security_attributes oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL (maybePtr Nothing) return $ if h == iNVALID_HANDLE_VALUE diff --git a/Utility/LockPool/STM.hs b/Utility/LockPool/STM.hs index 86e1bec06f..c47f003e35 100644 --- a/Utility/LockPool/STM.hs +++ b/Utility/LockPool/STM.hs @@ -22,6 +22,7 @@ module Utility.LockPool.STM ( import Utility.Monad import System.IO.Unsafe (unsafePerformIO) +import System.FilePath.ByteString (RawFilePath) import qualified Data.Map.Strict as M import Control.Concurrent.STM import Control.Exception @@ -29,7 +30,7 @@ import Control.Monad import Control.Applicative import Prelude -type LockFile = FilePath +type LockFile = RawFilePath data LockMode = LockExclusive | LockShared deriving (Eq) diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs index c7fe4cdf1f..b5b2ec20ef 100644 --- a/Utility/RawFilePath.hs +++ b/Utility/RawFilePath.hs @@ -18,6 +18,8 @@ module Utility.RawFilePath ( RawFilePath, readSymbolicLink, createSymbolicLink, + createLink, + removeLink, getFileStatus, getSymbolicLinkStatus, doesPathExist, @@ -56,6 +58,14 @@ createSymbolicLink a b = P.createSymbolicLink (fromRawFilePath a) (fromRawFilePath b) +createLink :: RawFilePath -> RawFilePath -> IO () +createLink a b = P.createLink + (fromRawFilePath a) + (fromRawFilePath b) + +removeLink :: RawFilePath -> IO () +removeLink = P.removeLink . fromRawFilePath + getFileStatus :: RawFilePath -> IO FileStatus getFileStatus = P.getFileStatus . fromRawFilePath