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