mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

more RawFilePath conversion

Browse source 
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.
This commit is contained in:
Joey Hess 2020-10-29 10:33:12 -04:00
parent 8d66f7ba0f
commit e505c03bcc
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
51 changed files with 182 additions and 153 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
Annex/AutoMerge.hs
View file

@ -176,7 +176,7 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
-- files, so delete here. -- files, so delete here.
unless inoverlay $ unless inoverlay $
unless (islocked LsFiles.valUs) $ unless (islocked LsFiles.valUs) $
liftIO $ nukeFile file liftIO $ removeWhenExistsWith removeLink file
| otherwise -> do | otherwise -> do
-- Only resolve using symlink when both -- Only resolve using symlink when both
-- were locked, otherwise use unlocked -- were locked, otherwise use unlocked
@ -309,7 +309,7 @@ cleanConflictCruft resolvedks resolvedfs unstagedmap = do
<$> mapM Database.Keys.getInodeCaches resolvedks <$> mapM Database.Keys.getInodeCaches resolvedks
forM_ (M.toList unstagedmap) $ \(i, f) -> forM_ (M.toList unstagedmap) $ \(i, f) ->
whenM (matchesresolved is i f) $ whenM (matchesresolved is i f) $
liftIO $ nukeFile f liftIO $ removeWhenExistsWith removeLink f
where where
fs = S.fromList resolvedfs fs = S.fromList resolvedfs
ks = S.fromList resolvedks ks = S.fromList resolvedks

2
Annex/Branch.hs
View file

@ -533,7 +533,7 @@ stageJournal jl commitindex = withIndex $ withOtherTmp $ \tmpdir -> do
stagedfs <- lines <$> hGetContents jlogh stagedfs <- lines <$> hGetContents jlogh
mapM_ (removeFile . (dir </>)) stagedfs mapM_ (removeFile . (dir </>)) stagedfs
hClose jlogh hClose jlogh
nukeFile jlogf removeWhenExistsWith removeLink jlogf
openjlog tmpdir = liftIO $ openTempFile tmpdir "jlog" openjlog tmpdir = liftIO $ openTempFile tmpdir "jlog"
{- This is run after the refs have been merged into the index, {- This is run after the refs have been merged into the index,

16
Annex/Content.hs
View file

@ -171,7 +171,7 @@ inAnnexSafe key =
Nothing -> return is_locked Nothing -> return is_locked
Just lockhandle -> do Just lockhandle -> do
dropLock lockhandle dropLock lockhandle
void $ tryIO $ nukeFile lockfile void $ tryIO $ removeWhenExistsWith removeLink lockfile
return is_unlocked return is_unlocked
, return is_missing , return is_missing
) )
@ -295,7 +295,7 @@ lockContentUsing locker key fallback a = do
cleanuplockfile lockfile = modifyContent lockfile $ cleanuplockfile lockfile = modifyContent lockfile $
void $ liftIO $ tryIO $ void $ liftIO $ tryIO $
nukeFile lockfile removeWhenExistsWith removeLink lockfile
{- Runs an action, passing it the temp file to get, {- Runs an action, passing it the temp file to get,
- and if the action succeeds, verifies the file matches - 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 -- including perhaps the content of another
-- file than the one that was requested, -- file than the one that was requested,
-- and so it's best not to keep it on disk. -- and so it's best not to keep it on disk.
pruneTmpWorkDirBefore tmpfile (liftIO . nukeFile) pruneTmpWorkDirBefore tmpfile (liftIO . removeWhenExistsWith removeLink)
return False return False
) )
-- On transfer failure, the tmp file is left behind, in case -- 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 withTmp key action = do
tmp <- prepTmp key tmp <- prepTmp key
res <- action tmp res <- action tmp
pruneTmpWorkDirBefore tmp (liftIO . nukeFile) pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith removeLink)
return res return res
{- Moves a key's content into .git/annex/objects/ {- 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] catMaybes [destic, Just srcic]
return LinkAnnexOk return LinkAnnexOk
_ -> do _ -> do
liftIO $ nukeFile dest liftIO $ removeWhenExistsWith removeLink dest
failed failed
{- Removes the annex object file for a key. Lowlevel. -} {- Removes the annex object file for a key. Lowlevel. -}
unlinkAnnex :: Key -> Annex () unlinkAnnex :: Key -> Annex ()
unlinkAnnex key = do unlinkAnnex key = do
obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) obj <- calcRepo (gitAnnexLocation key)
modifyContent obj $ do modifyContent obj $ do
secureErase obj secureErase obj
liftIO $ nukeFile obj liftIO $ removeWhenExistsWith R.removeLink obj
{- Runs an action to transfer an object's content. {- Runs an action to transfer an object's content.
- -
@ -674,7 +674,7 @@ removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file ->
cleanObjectLoc key $ do cleanObjectLoc key $ do
let file' = fromRawFilePath file let file' = fromRawFilePath file
secureErase file' secureErase file'
liftIO $ nukeFile file' liftIO $ removeWhenExistsWith removeLink file'
g <- Annex.gitRepo g <- Annex.gitRepo
mapM_ (\f -> void $ tryIO $ resetpointer $ fromTopFilePath f g) mapM_ (\f -> void $ tryIO $ resetpointer $ fromTopFilePath f g)
=<< Database.Keys.getAssociatedFiles key =<< Database.Keys.getAssociatedFiles key

7
Annex/Content/PointerFile.hs
View file

@ -25,6 +25,7 @@ import Utility.InodeCache
#if ! defined(mingw32_HOST_OS) #if ! defined(mingw32_HOST_OS)
import Utility.Touch import Utility.Touch
#endif #endif
import qualified Utility.RawFilePath as R
{- Populates a pointer file with the content of a key. {- Populates a pointer file with the content of a key.
- -
@ -37,8 +38,8 @@ populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f)
where where
go (Just k') | k == k' = do go (Just k') | k == k' = do
let f' = fromRawFilePath f let f' = fromRawFilePath f
destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f' destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus f
liftIO $ nukeFile f' liftIO $ removeWhenExistsWith R.removeLink f
(ic, populated) <- replaceWorkTreeFile f' $ \tmp -> do (ic, populated) <- replaceWorkTreeFile f' $ \tmp -> do
let tmp' = toRawFilePath tmp let tmp' = toRawFilePath tmp
ok <- linkOrCopy k (fromRawFilePath obj) tmp destmode >>= \case ok <- linkOrCopy k (fromRawFilePath obj) tmp destmode >>= \case
@ -61,7 +62,7 @@ depopulatePointerFile key file = do
st <- liftIO $ catchMaybeIO $ getFileStatus file' st <- liftIO $ catchMaybeIO $ getFileStatus file'
let mode = fmap fileMode st let mode = fmap fileMode st
secureErase file' secureErase file'
liftIO $ nukeFile file' liftIO $ removeWhenExistsWith R.removeLink file
ic <- replaceWorkTreeFile file' $ \tmp -> do ic <- replaceWorkTreeFile file' $ \tmp -> do
liftIO $ writePointerFile (toRawFilePath tmp) key mode liftIO $ writePointerFile (toRawFilePath tmp) key mode
#if ! defined(mingw32_HOST_OS) #if ! defined(mingw32_HOST_OS)

5
Annex/Fixup.hs
View file

@ -109,11 +109,10 @@ fixupUnusualRepos r@(Repo { location = l@(Local { worktree = Just w, gitdir = d
) )
where where
dotgit = w </> ".git" dotgit = w </> ".git"
dotgit' = fromRawFilePath dotgit
replacedotgit = whenM (doesFileExist dotgit') $ do replacedotgit = whenM (doesFileExist (fromRawFilePath dotgit)) $ do
linktarget <- relPathDirToFile w d linktarget <- relPathDirToFile w d
nukeFile dotgit' removeWhenExistsWith R.removeLink dotgit
R.createSymbolicLink linktarget dotgit R.createSymbolicLink linktarget dotgit
unsetcoreworktree = unsetcoreworktree =

6
Annex/Ingest.hs
View file

@ -112,7 +112,7 @@ lockDown' cfg file = tryIO $ ifM crippledFileSystem
(tmpfile, h) <- openTempFile tmpdir $ (tmpfile, h) <- openTempFile tmpdir $
relatedTemplate $ "ingest-" ++ takeFileName file relatedTemplate $ "ingest-" ++ takeFileName file
hClose h hClose h
nukeFile tmpfile removeWhenExistsWith removeLink tmpfile
withhardlink' delta tmpfile withhardlink' delta tmpfile
`catchIO` const (nohardlink' delta) `catchIO` const (nohardlink' delta)
@ -229,7 +229,7 @@ populateAssociatedFiles key source restage = do
cleanCruft :: KeySource -> Annex () cleanCruft :: KeySource -> Annex ()
cleanCruft source = when (contentLocation source /= keyFilename source) $ 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, -- 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 -- 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 :: FilePath -> Key -> SomeException -> Annex a
restoreFile file key e = do restoreFile file key e = do
whenM (inAnnex key) $ do whenM (inAnnex key) $ do
liftIO $ nukeFile file liftIO $ removeWhenExistsWith removeLink file
-- The key could be used by other files too, so leave the -- The key could be used by other files too, so leave the
-- content in the annex, and make a copy back to the file. -- content in the annex, and make a copy back to the file.
obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key)

16
Annex/Init.hs
View file

@ -208,9 +208,9 @@ probeCrippledFileSystem' tmp = do
where where
probe f = catchDefaultIO (True, []) $ do probe f = catchDefaultIO (True, []) $ do
let f2 = f ++ "2" let f2 = f ++ "2"
nukeFile f2 removeWhenExistsWith removeLink f2
createSymbolicLink f f2 createSymbolicLink f f2
nukeFile f2 removeWhenExistsWith removeLink f2
preventWrite f preventWrite f
-- Should be unable to write to the file, unless -- Should be unable to write to the file, unless
-- running as root, but some crippled -- running as root, but some crippled
@ -251,13 +251,13 @@ probeLockSupport = withEventuallyCleanedOtherTmp $ \tmp -> do
liftIO $ withAsync warnstall (const (go f mode)) liftIO $ withAsync warnstall (const (go f mode))
where where
go f mode = do go f mode = do
nukeFile f removeWhenExistsWith removeLink f
let locktest = bracket let locktest = bracket
(Posix.lockExclusive (Just mode) f) (Posix.lockExclusive (Just mode) f)
Posix.dropLock Posix.dropLock
(const noop) (const noop)
ok <- isRight <$> tryNonAsync locktest ok <- isRight <$> tryNonAsync locktest
nukeFile f removeWhenExistsWith removeLink f
return ok return ok
warnstall = do warnstall = do
@ -275,14 +275,14 @@ probeFifoSupport = do
let f = tmp </> "gaprobe" let f = tmp </> "gaprobe"
let f2 = tmp </> "gaprobe2" let f2 = tmp </> "gaprobe2"
liftIO $ do liftIO $ do
nukeFile f removeWhenExistsWith removeLink f
nukeFile f2 removeWhenExistsWith removeLink f2
ms <- tryIO $ do ms <- tryIO $ do
createNamedPipe f ownerReadMode createNamedPipe f ownerReadMode
createLink f f2 createLink f f2
getFileStatus f getFileStatus f
nukeFile f removeWhenExistsWith removeLink f
nukeFile f2 removeWhenExistsWith removeLink f2
return $ either (const False) isNamedPipe ms return $ either (const False) isNamedPipe ms
#endif #endif

8
Annex/Locations.hs
View file

@ -505,12 +505,12 @@ gitAnnexIgnoredRefs :: Git.Repo -> FilePath
gitAnnexIgnoredRefs r = fromRawFilePath $ gitAnnexDir r P.</> "ignoredrefs" gitAnnexIgnoredRefs r = fromRawFilePath $ gitAnnexDir r P.</> "ignoredrefs"
{- Pid file for daemon mode. -} {- Pid file for daemon mode. -}
gitAnnexPidFile :: Git.Repo -> FilePath gitAnnexPidFile :: Git.Repo -> RawFilePath
gitAnnexPidFile r = fromRawFilePath $ gitAnnexDir r P.</> "daemon.pid" gitAnnexPidFile r = gitAnnexDir r P.</> "daemon.pid"
{- Pid lock file for pidlock mode -} {- Pid lock file for pidlock mode -}
gitAnnexPidLockFile :: Git.Repo -> FilePath gitAnnexPidLockFile :: Git.Repo -> RawFilePath
gitAnnexPidLockFile r = fromRawFilePath $ gitAnnexDir r P.</> "pidlock" gitAnnexPidLockFile r = gitAnnexDir r P.</> "pidlock"
{- Status file for daemon mode. -} {- Status file for daemon mode. -}
gitAnnexDaemonStatusFile :: Git.Repo -> FilePath gitAnnexDaemonStatusFile :: Git.Repo -> FilePath

12
Annex/LockFile.hs
View file

@ -30,7 +30,7 @@ import qualified System.FilePath.ByteString as P
{- Create a specified lock file, and takes a shared lock, which is retained {- Create a specified lock file, and takes a shared lock, which is retained
- in the cache. -} - in the cache. -}
lockFileCached :: FilePath -> Annex () lockFileCached :: RawFilePath -> Annex ()
lockFileCached file = go =<< fromLockCache file lockFileCached file = go =<< fromLockCache file
where where
go (Just _) = noop -- already locked go (Just _) = noop -- already locked
@ -43,7 +43,7 @@ lockFileCached file = go =<< fromLockCache file
#endif #endif
changeLockCache $ M.insert file lockhandle changeLockCache $ M.insert file lockhandle
unlockFile :: FilePath -> Annex () unlockFile :: RawFilePath -> Annex ()
unlockFile file = maybe noop go =<< fromLockCache file unlockFile file = maybe noop go =<< fromLockCache file
where where
go lockhandle = do go lockhandle = do
@ -53,7 +53,7 @@ unlockFile file = maybe noop go =<< fromLockCache file
getLockCache :: Annex LockCache getLockCache :: Annex LockCache
getLockCache = getState lockcache getLockCache = getState lockcache
fromLockCache :: FilePath -> Annex (Maybe LockHandle) fromLockCache :: RawFilePath -> Annex (Maybe LockHandle)
fromLockCache file = M.lookup file <$> getLockCache fromLockCache file = M.lookup file <$> getLockCache
changeLockCache :: (LockCache -> LockCache) -> Annex () changeLockCache :: (LockCache -> LockCache) -> Annex ()
@ -68,7 +68,7 @@ withSharedLock getlockfile a = debugLocks $ do
lockfile <- fromRepo getlockfile lockfile <- fromRepo getlockfile
createAnnexDirectory $ P.takeDirectory lockfile createAnnexDirectory $ P.takeDirectory lockfile
mode <- annexFileMode mode <- annexFileMode
bracket (lock mode (fromRawFilePath lockfile)) (liftIO . dropLock) (const a) bracket (lock mode lockfile) (liftIO . dropLock) (const a)
where where
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
lock mode = noUmask mode . lockShared (Just mode) lock mode = noUmask mode . lockShared (Just mode)
@ -90,7 +90,7 @@ takeExclusiveLock getlockfile = debugLocks $ do
lockfile <- fromRepo getlockfile lockfile <- fromRepo getlockfile
createAnnexDirectory $ P.takeDirectory lockfile createAnnexDirectory $ P.takeDirectory lockfile
mode <- annexFileMode mode <- annexFileMode
lock mode (fromRawFilePath lockfile) lock mode lockfile
where where
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
lock mode = noUmask mode . lockExclusive (Just mode) lock mode = noUmask mode . lockExclusive (Just mode)
@ -105,7 +105,7 @@ tryExclusiveLock getlockfile a = debugLocks $ do
lockfile <- fromRepo getlockfile lockfile <- fromRepo getlockfile
createAnnexDirectory $ P.takeDirectory lockfile createAnnexDirectory $ P.takeDirectory lockfile
mode <- annexFileMode mode <- annexFileMode
bracket (lock mode (fromRawFilePath lockfile)) (liftIO . unlock) go bracket (lock mode lockfile) (liftIO . unlock) go
where where
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
lock mode = noUmask mode . tryLockExclusive (Just mode) lock mode = noUmask mode . tryLockExclusive (Just mode)

2
Annex/Ssh.hs
View file

@ -333,7 +333,7 @@ forceStopSsh socketfile = withNullHandle $ \nullh -> do
} }
void $ liftIO $ catchMaybeIO $ withCreateProcess p $ \_ _ _ pid -> void $ liftIO $ catchMaybeIO $ withCreateProcess p $ \_ _ _ pid ->
forceSuccessProcess 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 {- 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 - of the path to a socket file. At the same time, it needs to be unique

2
Annex/Tmp.hs
View file

@ -67,5 +67,5 @@ cleanupOtherTmp = do
let oldenough = now - (60 * 60 * 24 * 7) let oldenough = now - (60 * 60 * 24 * 7)
catchMaybeIO (modificationTime <$> getSymbolicLinkStatus f) >>= \case catchMaybeIO (modificationTime <$> getSymbolicLinkStatus f) >>= \case
Just mtime | realToFrac mtime <= oldenough -> Just mtime | realToFrac mtime <= oldenough ->
void $ tryIO $ nukeFile f void $ tryIO $ removeWhenExistsWith removeLink f
_ -> return () _ -> return ()

2
Annex/View.hs
View file

@ -353,7 +353,7 @@ applyView' :: MkViewedFile -> (FilePath -> MetaData) -> View -> Annex Git.Branch
applyView' mkviewedfile getfilemetadata view = do applyView' mkviewedfile getfilemetadata view = do
top <- fromRepo Git.repoPath top <- fromRepo Git.repoPath
(l, clean) <- inRepo $ Git.LsFiles.inRepoDetails [] [top] (l, clean) <- inRepo $ Git.LsFiles.inRepoDetails [] [top]
liftIO . nukeFile =<< fromRepo gitAnnexViewIndex liftIO . removeWhenExistsWith removeLink =<< fromRepo gitAnnexViewIndex
viewg <- withViewIndex gitRepo viewg <- withViewIndex gitRepo
withUpdateIndex viewg $ \uh -> do withUpdateIndex viewg $ \uh -> do
forM_ l $ \(f, sha, mode) -> do forM_ l $ \(f, sha, mode) -> do

2
Assistant/Repair.hs
View file

@ -148,7 +148,7 @@ repairStaleLocks lockfiles = go =<< getsizes
waitforit "to check stale git lock file" waitforit "to check stale git lock file"
l' <- getsizes l' <- getsizes
if l' == l if l' == l
then liftIO $ mapM_ nukeFile (map fst l) then liftIO $ mapM_ (removeWhenExistsWith removeLink . fst) l
else go l' else go l'
, do , do
waitforit "for git lock file writer" waitforit "for git lock file writer"

4
Assistant/Restart.hs
View file

@ -39,8 +39,8 @@ import Network.URI
prepRestart :: Assistant () prepRestart :: Assistant ()
prepRestart = do prepRestart = do
liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread
liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexUrlFile) liftIO . removeWhenExistsWith removeLink =<< liftAnnex (fromRepo gitAnnexUrlFile)
liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexPidFile) liftIO . removeWhenExistsWith removeLink =<< liftAnnex (fromRepo gitAnnexPidFile)
{- To finish a restart, send a global redirect to the new url {- To finish a restart, send a global redirect to the new url
- to any web browsers that are displaying the webapp. - to any web browsers that are displaying the webapp.

4
Assistant/Threads/SanityChecker.hs
View file

@ -66,7 +66,7 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta
ifM (not <$> liftAnnex (inRepo checkIndexFast)) ifM (not <$> liftAnnex (inRepo checkIndexFast))
( do ( do
notice ["corrupt index file found at startup; removing and restaging"] 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, {- Normally the startup scan avoids re-staging files,
- but with the index deleted, everything needs to be - but with the index deleted, everything needs to be
- restaged. -} - restaged. -}
@ -80,7 +80,7 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta
- will be automatically regenerated. -} - will be automatically regenerated. -}
unlessM (liftAnnex $ Annex.Branch.withIndex $ inRepo $ Git.Repair.checkIndexFast) $ do unlessM (liftAnnex $ Annex.Branch.withIndex $ inRepo $ Git.Repair.checkIndexFast) $ do
notice ["corrupt annex/index file found at startup; removing"] 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. -} {- Fix up ssh remotes set up by past versions of the assistant. -}
liftIO $ fixUpSshRemotes liftIO $ fixUpSshRemotes

6
Assistant/Upgrade.hs
View file

@ -220,7 +220,7 @@ upgradeToDistribution newdir cleanup distributionfile = do
error $ "did not find " ++ dir ++ " in " ++ distributionfile error $ "did not find " ++ dir ++ " in " ++ distributionfile
makeorigsymlink olddir = do makeorigsymlink olddir = do
let origdir = parentDir olddir </> installBase let origdir = parentDir olddir </> installBase
nukeFile origdir removeWhenExistsWith removeLink origdir
createSymbolicLink newdir origdir createSymbolicLink newdir origdir
{- Finds where the old version was installed. -} {- Finds where the old version was installed. -}
@ -278,8 +278,8 @@ installBase = "git-annex." ++
deleteFromManifest :: FilePath -> IO () deleteFromManifest :: FilePath -> IO ()
deleteFromManifest dir = do deleteFromManifest dir = do
fs <- map (dir </>) . lines <$> catchDefaultIO "" (readFile manifest) fs <- map (dir </>) . lines <$> catchDefaultIO "" (readFile manifest)
mapM_ nukeFile fs mapM_ (removeWhenExistsWith removeLink) fs
nukeFile manifest removeWhenExistsWith removeLink manifest
removeEmptyRecursive dir removeEmptyRecursive dir
where where
manifest = dir </> "git-annex.MANIFEST" manifest = dir </> "git-annex.MANIFEST"

8
Build/DistributionUpdate.hs
View file

@ -83,10 +83,10 @@ getbuild repodir (url, f) = do
bv1 <- getbv bv1 <- getbv
let dest = repodir </> f let dest = repodir </> f
let tmp = dest ++ ".tmp" let tmp = dest ++ ".tmp"
nukeFile tmp removeWhenExistsWith removeFile tmp
createDirectoryIfMissing True (parentDir dest) createDirectoryIfMissing True (parentDir dest)
let oops s = do let oops s = do
nukeFile tmp removeWhenExistsWith removeFile tmp
putStrLn $ "*** " ++ s putStrLn $ "*** " ++ s
return Nothing return Nothing
uo <- defUrlOptions uo <- defUrlOptions
@ -98,7 +98,7 @@ getbuild repodir (url, f) = do
Nothing -> oops $ "no build-version file for " ++ url Nothing -> oops $ "no build-version file for " ++ url
(Just v) (Just v)
| bv2 == bv1 -> do | bv2 == bv1 -> do
nukeFile dest removeWhenExistsWith removeFile dest
renameFile tmp dest renameFile tmp dest
-- remove git rev part of version -- remove git rev part of version
let v' = takeWhile (/= '-') v let v' = takeWhile (/= '-') v
@ -228,7 +228,7 @@ buildrpms topdir l = do
<$> liftIO (getDirectoryContents rpmrepo) <$> liftIO (getDirectoryContents rpmrepo)
forM_ tarrpmarches $ \(tararch, rpmarch) -> forM_ tarrpmarches $ \(tararch, rpmarch) ->
forM_ (filter (isstandalonetarball tararch . fst) l) $ \(tarball, v) -> do 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 void $ liftIO $ boolSystem script
[ Param rpmarch [ Param rpmarch
, File tarball , File tarball

4
Build/LinuxMkLibs.hs
View file

@ -99,8 +99,8 @@ installLinkerShim top linker exe = do
ifM (isSymbolicLink <$> getSymbolicLinkStatus exe) ifM (isSymbolicLink <$> getSymbolicLinkStatus exe)
( do ( do
sl <- readSymbolicLink exe sl <- readSymbolicLink exe
nukeFile exe removeWhenExistsWith removeLink exe
nukeFile exedest removeWhenExistsWith removeLink exedest
-- Assume that for a symlink, the destination -- Assume that for a symlink, the destination
-- will also be shimmed. -- will also be shimmed.
let sl' = ".." </> takeFileName sl </> takeFileName sl let sl' = ".." </> takeFileName sl </> takeFileName sl

4
Build/Standalone.hs
View file

@ -95,7 +95,7 @@ installGitLibs topdir = do
unlessM (doesFileExist linktarget') $ do unlessM (doesFileExist linktarget') $ do
createDirectoryIfMissing True (takeDirectory linktarget') createDirectoryIfMissing True (takeDirectory linktarget')
L.readFile f >>= L.writeFile linktarget' L.readFile f >>= L.writeFile linktarget'
nukeFile destf removeWhenExistsWith removeLink destf
rellinktarget <- relPathDirToFile (takeDirectory destf) linktarget' rellinktarget <- relPathDirToFile (takeDirectory destf) linktarget'
createSymbolicLink rellinktarget destf createSymbolicLink rellinktarget destf
else cp f destf else cp f destf
@ -125,7 +125,7 @@ installGitLibs topdir = do
cp :: FilePath -> FilePath -> IO () cp :: FilePath -> FilePath -> IO ()
cp src dest = do cp src dest = do
nukeFile dest removeWhenExistsWith removeLink dest
unlessM (boolSystem "cp" [Param "-a", File src, File dest]) $ unlessM (boolSystem "cp" [Param "-a", File src, File dest]) $
error "cp failed" error "cp failed"

4
Command/AddUrl.hs
View file

@ -326,7 +326,7 @@ downloadWeb addunlockedmatcher o url urlinfo file =
Left _ -> normalfinish tmp Left _ -> normalfinish tmp
where where
dl dest = withTmpWorkDir mediakey $ \workdir -> do dl dest = withTmpWorkDir mediakey $ \workdir -> do
let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . nukeFile) let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith removeLink)
showNote "using youtube-dl" showNote "using youtube-dl"
Transfer.notifyTransfer Transfer.Download url $ Transfer.notifyTransfer Transfer.Download url $
Transfer.download webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \p -> Transfer.download webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \p ->
@ -446,7 +446,7 @@ addWorkTree _ addunlockedmatcher u url file key mtmp = case mtmp of
( do ( do
when (isJust mtmp) $ when (isJust mtmp) $
logStatus key InfoPresent 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 -- git does not need to check ignores, because that has already

2
Command/DropUnused.hs
View file

@ -66,5 +66,5 @@ perform from numcopies key = case from of
performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform
performOther filespec key = do performOther filespec key = do
f <- fromRepo $ filespec key f <- fromRepo $ filespec key
pruneTmpWorkDirBefore f (liftIO . nukeFile) pruneTmpWorkDirBefore f (liftIO . removeWhenExistsWith removeLink)
next $ return True next $ return True

5
Command/Fsck.hs
View file

@ -584,7 +584,7 @@ recordStartTime :: UUID -> Annex ()
recordStartTime u = do recordStartTime u = do
f <- fromRepo (gitAnnexFsckState u) f <- fromRepo (gitAnnexFsckState u)
createAnnexDirectory $ parentDir f createAnnexDirectory $ parentDir f
liftIO $ nukeFile f liftIO $ removeWhenExistsWith removeLink f
liftIO $ withFile f WriteMode $ \h -> do liftIO $ withFile f WriteMode $ \h -> do
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
t <- modificationTime <$> getFileStatus f t <- modificationTime <$> getFileStatus f
@ -598,7 +598,8 @@ recordStartTime u = do
showTime = show showTime = show
resetStartTime :: UUID -> Annex () resetStartTime :: UUID -> Annex ()
resetStartTime u = liftIO . nukeFile =<< fromRepo (gitAnnexFsckState u) resetStartTime u = liftIO . removeWhenExistsWith removeLink
=<< fromRepo (gitAnnexFsckState u)
{- Gets the incremental fsck start time. -} {- Gets the incremental fsck start time. -}
getStartTime :: UUID -> Annex (Maybe EpochTime) getStartTime :: UUID -> Annex (Maybe EpochTime)

3
Command/FuzzTest.hs
View file

@ -177,7 +177,8 @@ runFuzzAction (FuzzAdd (FuzzFile f)) = do
createWorkTreeDirectory (parentDir f) createWorkTreeDirectory (parentDir f)
n <- liftIO (getStdRandom random :: IO Int) n <- liftIO (getStdRandom random :: IO Int)
liftIO $ writeFile f $ show n ++ "\n" 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 $ runFuzzAction (FuzzMove (FuzzFile src) (FuzzFile dest)) = liftIO $
rename src dest rename src dest
runFuzzAction (FuzzDeleteDir (FuzzDir d)) = liftIO $ runFuzzAction (FuzzDeleteDir (FuzzDir d)) = liftIO $

4
Command/Import.hs
View file

@ -175,13 +175,13 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
| isDirectory s -> notoverwriting "(is a directory)" | isDirectory s -> notoverwriting "(is a directory)"
| isSymbolicLink s -> ifM (Annex.getState Annex.force) | isSymbolicLink s -> ifM (Annex.getState Annex.force)
( do ( do
liftIO $ nukeFile destfile liftIO $ removeWhenExistsWith removeLink destfile
importfilechecked ld k importfilechecked ld k
, notoverwriting "(is a symlink)" , notoverwriting "(is a symlink)"
) )
| otherwise -> ifM (Annex.getState Annex.force) | otherwise -> ifM (Annex.getState Annex.force)
( do ( do
liftIO $ nukeFile destfile liftIO $ removeWhenExistsWith removeLink destfile
importfilechecked ld k importfilechecked ld k
, notoverwriting "(use --force to override, or a duplication option such as --deduplicate to clean up)" , notoverwriting "(use --force to override, or a duplication option such as --deduplicate to clean up)"
) )

2
Command/Lock.hs
View file

@ -89,7 +89,7 @@ perform file key = do
fs <- map (`fromTopFilePath` g) fs <- map (`fromTopFilePath` g)
<$> Database.Keys.getAssociatedFiles key <$> Database.Keys.getAssociatedFiles key
mfile <- firstM (isUnmodified key) fs mfile <- firstM (isUnmodified key) fs
liftIO $ nukeFile obj liftIO $ removeWhenExistsWith removeLink obj
case mfile of case mfile of
Just unmodified -> Just unmodified ->
unlessM (checkedCopyFile key (fromRawFilePath unmodified) obj Nothing) unlessM (checkedCopyFile key (fromRawFilePath unmodified) obj Nothing)

4
Command/Multicast.hs
View file

@ -84,7 +84,7 @@ genAddress = starting "gen-address" (ActionItemOther Nothing) (SeekInput []) $ d
KeyContainer s -> liftIO $ genkey (Param s) KeyContainer s -> liftIO $ genkey (Param s)
KeyFile f -> do KeyFile f -> do
createAnnexDirectory (takeDirectory f) createAnnexDirectory (takeDirectory f)
liftIO $ nukeFile f liftIO $ removeWhenExistsWith removeLink f
liftIO $ protectedOutput $ genkey (File f) liftIO $ protectedOutput $ genkey (File f)
case (ok, parseFingerprint s) of case (ok, parseFingerprint s) of
(False, _) -> giveup $ "uftp_keymgt failed: " ++ s (False, _) -> giveup $ "uftp_keymgt failed: " ++ s
@ -210,7 +210,7 @@ storeReceived f = do
case deserializeKey (takeFileName f) of case deserializeKey (takeFileName f) of
Nothing -> do Nothing -> do
warning $ "Received a file " ++ f ++ " that is not a git-annex key. Deleting this file." 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 $ Just k -> void $
getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k $ \dest -> unVerified $ getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k $ \dest -> unVerified $
liftIO $ catchBoolIO $ do liftIO $ catchBoolIO $ do

2
Command/P2P.hs
View file

@ -256,7 +256,7 @@ wormholePairing remotename ouraddrs ui = do
Wormhole.sendFile sendf observer wormholeparams Wormhole.sendFile sendf observer wormholeparams
`concurrently` `concurrently`
Wormhole.receiveFile recvf producer wormholeparams Wormhole.receiveFile recvf producer wormholeparams
liftIO $ nukeFile sendf liftIO $ removeWhenExistsWith removeLink sendf
if sendres /= True if sendres /= True
then return SendFailed then return SendFailed
else if recvres /= True else if recvres /= True

2
Command/Repair.hs
View file

@ -75,7 +75,7 @@ repairAnnexBranch modifiedbranches
Annex.Branch.forceCommit "committing index after git repository repair" Annex.Branch.forceCommit "committing index after git repository repair"
liftIO $ putStrLn "Successfully recovered the git-annex branch using .git/annex/index" liftIO $ putStrLn "Successfully recovered the git-annex branch using .git/annex/index"
nukeindex = do nukeindex = do
inRepo $ nukeFile . gitAnnexIndex inRepo $ removeWhenExistsWith removeLink . gitAnnexIndex
liftIO $ putStrLn "Had to delete the .git/annex/index file as it was corrupt." 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" 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"

2
Command/Undo.hs
View file

@ -67,7 +67,7 @@ perform p = do
forM_ removals $ \di -> do forM_ removals $ \di -> do
f <- mkrel di f <- mkrel di
liftIO $ nukeFile f liftIO $ removeWhenExistsWith removeLink f
forM_ adds $ \di -> do forM_ adds $ \di -> do
f <- mkrel di f <- mkrel di

2
Command/Vicfg.hs
View file

@ -57,7 +57,7 @@ vicfg curcfg f = do
unlessM (liftIO $ boolSystem "sh" [Param "-c", Param $ unwords [vi, shellEscape f]]) $ unlessM (liftIO $ boolSystem "sh" [Param "-c", Param $ unwords [vi, shellEscape f]]) $
giveup $ vi ++ " exited nonzero; aborting" giveup $ vi ++ " exited nonzero; aborting"
r <- parseCfg (defCfg curcfg) <$> liftIO (readFileStrict f) r <- parseCfg (defCfg curcfg) <$> liftIO (readFileStrict f)
liftIO $ nukeFile f liftIO $ removeWhenExistsWith removeLink f
case r of case r of
Left s -> do Left s -> do
liftIO $ writeFile f s liftIO $ writeFile f s

2
Config.hs
View file

@ -85,7 +85,7 @@ setCrippledFileSystem :: Bool -> Annex ()
setCrippledFileSystem b = setCrippledFileSystem b =
setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b) setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b)
pidLockFile :: Annex (Maybe FilePath) pidLockFile :: Annex (Maybe RawFilePath)
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
pidLockFile = ifM (annexPidLock <$> Annex.getGitConfig) pidLockFile = ifM (annexPidLock <$> Annex.getGitConfig)
( Just <$> Annex.fromRepo gitAnnexPidLockFile ( Just <$> Annex.fromRepo gitAnnexPidLockFile

2
Creds.hs
View file

@ -212,7 +212,7 @@ removeCreds :: FilePath -> Annex ()
removeCreds file = do removeCreds file = do
d <- fromRawFilePath <$> fromRepo gitAnnexCredsDir d <- fromRawFilePath <$> fromRepo gitAnnexCredsDir
let f = d </> file let f = d </> file
liftIO $ nukeFile f liftIO $ removeWhenExistsWith removeLink f
includeCredsInfo :: ParsedRemoteConfig -> CredPairStorage -> [(String, String)] -> Annex [(String, String)] includeCredsInfo :: ParsedRemoteConfig -> CredPairStorage -> [(String, String)] -> Annex [(String, String)]
includeCredsInfo pc@(ParsedRemoteConfig cm _) storage info = do includeCredsInfo pc@(ParsedRemoteConfig cm _) storage info = do

15
Git/Repair.hs
View file

@ -39,6 +39,7 @@ import Utility.Directory.Create
import Utility.Tmp.Dir import Utility.Tmp.Dir
import Utility.Rsync import Utility.Rsync
import Utility.FileMode import Utility.FileMode
import qualified Utility.RawFilePath as R
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
@ -52,7 +53,7 @@ cleanCorruptObjects fsckresults r = do
mapM_ removeLoose (S.toList $ knownMissing fsckresults) mapM_ removeLoose (S.toList $ knownMissing fsckresults)
mapM_ removeBad =<< listLooseObjectShas r mapM_ removeBad =<< listLooseObjectShas r
where where
removeLoose s = nukeFile (looseObjectFile r s) removeLoose s = removeWhenExistsWith removeLink (looseObjectFile r s)
removeBad s = do removeBad s = do
void $ tryIO $ allowRead $ looseObjectFile r s void $ tryIO $ allowRead $ looseObjectFile r s
whenM (isMissing s r) $ whenM (isMissing s r) $
@ -78,7 +79,7 @@ explodePacks r = go =<< listPackFiles r
putStrLn "Unpacking all pack files." putStrLn "Unpacking all pack files."
forM_ packs $ \packfile -> do forM_ packs $ \packfile -> do
moveFile packfile (tmpdir </> takeFileName packfile) moveFile packfile (tmpdir </> takeFileName packfile)
nukeFile $ packIdxFile packfile removeWhenExistsWith removeLink $ packIdxFile packfile
forM_ packs $ \packfile -> do forM_ packs $ \packfile -> do
let tmp = tmpdir </> takeFileName packfile let tmp = tmpdir </> takeFileName packfile
allowRead tmp allowRead tmp
@ -245,7 +246,7 @@ explodePackedRefsFile r = do
rs <- mapMaybe parsePacked . lines rs <- mapMaybe parsePacked . lines
<$> catchDefaultIO "" (safeReadFile f) <$> catchDefaultIO "" (safeReadFile f)
forM_ rs makeref forM_ rs makeref
nukeFile f removeWhenExistsWith removeLink f
where where
makeref (sha, ref) = do makeref (sha, ref) = do
let gitd = localGitDir r 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 {- git-branch -d cannot be used to remove a branch that is directly
- pointing to a corrupt commit. -} - pointing to a corrupt commit. -}
nukeBranchRef :: Branch -> Repo -> IO () 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 {- 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. - of the missing objects. If the input branch is good as-is, returns it.
@ -394,7 +395,7 @@ rewriteIndex r
| otherwise = do | otherwise = do
(bad, good, cleanup) <- partitionIndex r (bad, good, cleanup) <- partitionIndex r
unless (null bad) $ do unless (null bad) $ do
nukeFile (indexFile r) removeWhenExistsWith removeLink (indexFile r)
UpdateIndex.streamUpdateIndex r UpdateIndex.streamUpdateIndex r
=<< (catMaybes <$> mapM reinject good) =<< (catMaybes <$> mapM reinject good)
void cleanup void cleanup
@ -442,7 +443,7 @@ displayList items header
preRepair :: Repo -> IO () preRepair :: Repo -> IO ()
preRepair g = do preRepair g = do
unlessM (validhead <$> catchDefaultIO "" (safeReadFile headfile)) $ do unlessM (validhead <$> catchDefaultIO "" (safeReadFile headfile)) $ do
nukeFile headfile removeWhenExistsWith removeLink headfile
writeFile headfile "ref: refs/heads/master" writeFile headfile "ref: refs/heads/master"
explodePackedRefsFile g explodePackedRefsFile g
unless (repoIsLocalBare g) $ do unless (repoIsLocalBare g) $ do
@ -571,7 +572,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do
else successfulfinish modifiedbranches else successfulfinish modifiedbranches
corruptedindex = do corruptedindex = do
nukeFile (indexFile g) removeWhenExistsWith removeLink (indexFile g)
-- The corrupted index can prevent fsck from finding other -- The corrupted index can prevent fsck from finding other
-- problems, so re-run repair. -- problems, so re-run repair.
fsckresult' <- findBroken False g fsckresult' <- findBroken False g

5
Logs/FsckResults.hs
View file

@ -24,7 +24,7 @@ writeFsckResults u fsckresults = do
case fsckresults of case fsckresults of
FsckFailed -> store S.empty False logfile FsckFailed -> store S.empty False logfile
FsckFoundMissing s t FsckFoundMissing s t
| S.null s -> liftIO $ nukeFile logfile | S.null s -> liftIO $ removeWhenExistsWith removeLink logfile
| otherwise -> store s t logfile | otherwise -> store s t logfile
where where
store s t logfile = writeLogFile logfile $ serialize s t 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 in if S.null s then FsckFailed else FsckFoundMissing s t
clearFsckResults :: UUID -> Annex () clearFsckResults :: UUID -> Annex ()
clearFsckResults = liftIO . nukeFile <=< fromRepo . gitAnnexFsckResultsLog clearFsckResults = liftIO . removeWhenExistsWith removeLink
<=< fromRepo . gitAnnexFsckResultsLog

2
P2P/IO.hs
View file

@ -124,7 +124,7 @@ closeConnection conn = do
-- the callback. -- the callback.
serveUnixSocket :: FilePath -> (Handle -> IO ()) -> IO () serveUnixSocket :: FilePath -> (Handle -> IO ()) -> IO ()
serveUnixSocket unixsocket serveconn = do serveUnixSocket unixsocket serveconn = do
nukeFile unixsocket removeWhenExistsWith removeLink unixsocket
soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
S.bind soc (S.SockAddrUnix unixsocket) S.bind soc (S.SockAddrUnix unixsocket)
-- Allow everyone to read and write to the socket, -- Allow everyone to read and write to the socket,

2
Remote/BitTorrent.hs
View file

@ -179,7 +179,7 @@ tmpTorrentFile u = fromRepo . gitAnnexTmpObjectLocation =<< torrentUrlKey u
-} -}
registerTorrentCleanup :: URLString -> Annex () registerTorrentCleanup :: URLString -> Annex ()
registerTorrentCleanup u = Annex.addCleanup (TorrentCleanup u) $ registerTorrentCleanup u = Annex.addCleanup (TorrentCleanup u) $
liftIO . nukeFile =<< tmpTorrentFile u liftIO . removeWhenExistsWith removeLink =<< tmpTorrentFile u
{- Downloads the torrent file. (Not its contents.) -} {- Downloads the torrent file. (Not its contents.) -}
downloadTorrentFile :: URLString -> Annex Bool downloadTorrentFile :: URLString -> Annex Bool

2
Remote/Directory.hs
View file

@ -284,7 +284,7 @@ retrieveExportM d _k loc dest p =
removeExportM :: FilePath -> Key -> ExportLocation -> Annex () removeExportM :: FilePath -> Key -> ExportLocation -> Annex ()
removeExportM d _k loc = liftIO $ do removeExportM d _k loc = liftIO $ do
nukeFile src removeWhenExistsWith removeLink src
removeExportLocation d loc removeExportLocation d loc
where where
src = exportPath d loc src = exportPath d loc

2
Remote/Directory/LegacyChunked.hs
View file

@ -98,7 +98,7 @@ retrieve locations d basek p c = withOtherTmp $ \tmpdir -> do
S.appendFile tmp <=< S.readFile S.appendFile tmp <=< S.readFile
return True return True
b <- liftIO $ L.readFile tmp b <- liftIO $ L.readFile tmp
liftIO $ nukeFile tmp liftIO $ removeWhenExistsWith removeLink tmp
sink b sink b
byteRetriever go basek p c byteRetriever go basek p c

4
Remote/Helper/Special.hs
View file

@ -283,10 +283,10 @@ sink dest enc c mh mp content = case (enc, mh, content) of
withBytes content $ \b -> withBytes content $ \b ->
decrypt cmd c cipher (feedBytes b) $ decrypt cmd c cipher (feedBytes b) $
readBytes write readBytes write
liftIO $ nukeFile f liftIO $ removeWhenExistsWith removeLink f
(Nothing, _, FileContent f) -> do (Nothing, _, FileContent f) -> do
withBytes content write withBytes content write
liftIO $ nukeFile f liftIO $ removeWhenExistsWith removeLink f
(Nothing, _, ByteContent b) -> write b (Nothing, _, ByteContent b) -> write b
where where
write b = case mh of write b = case mh of

13
Test.hs
View file

@ -409,7 +409,7 @@ test_ignore_deleted_files :: Assertion
test_ignore_deleted_files = intmpclonerepo $ do test_ignore_deleted_files = intmpclonerepo $ do
git_annex "get" [annexedfile] @? "get failed" git_annex "get" [annexedfile] @? "get failed"
git_annex_expectoutput "find" [] [annexedfile] git_annex_expectoutput "find" [] [annexedfile]
nukeFile annexedfile removeWhenExistsWith removeLink annexedfile
-- A file that has been deleted, but the deletion not staged, -- A file that has been deleted, but the deletion not staged,
-- is a special case; make sure git-annex skips these. -- is a special case; make sure git-annex skips these.
git_annex_expectoutput "find" [] [] git_annex_expectoutput "find" [] []
@ -759,7 +759,8 @@ test_lock_force = intmpclonerepo $ do
Just k <- Annex.WorkTree.lookupKey (toRawFilePath annexedfile) Just k <- Annex.WorkTree.lookupKey (toRawFilePath annexedfile)
Database.Keys.removeInodeCaches k Database.Keys.removeInodeCaches k
Database.Keys.closeDb Database.Keys.closeDb
liftIO . nukeFile =<< Annex.fromRepo Annex.Locations.gitAnnexKeysDbIndexCache liftIO . removeWhenExistsWith removeLink
=<< Annex.fromRepo Annex.Locations.gitAnnexKeysDbIndexCache
writecontent annexedfile "test_lock_force content" writecontent annexedfile "test_lock_force content"
git_annex_shouldfail "lock" [annexedfile] @? "lock of modified file failed to fail" git_annex_shouldfail "lock" [annexedfile] @? "lock of modified file failed to fail"
git_annex "lock" ["--force", annexedfile] @? "lock --force of modified file failed" git_annex "lock" ["--force", annexedfile] @? "lock --force of modified file failed"
@ -1306,7 +1307,7 @@ test_remove_conflict_resolution = do
@? "unlock conflictor failed" @? "unlock conflictor failed"
writecontent conflictor "newconflictor" writecontent conflictor "newconflictor"
indir r1 $ indir r1 $
nukeFile conflictor removeWhenExistsWith removeLink conflictor
let l = if inr1 then [r1, r2, r1] else [r2, r1, r2] let l = if inr1 then [r1, r2, r1] else [r2, r1, r2]
forM_ l $ \r -> indir r $ forM_ l $ \r -> indir r $
git_annex "sync" [] @? "sync failed" git_annex "sync" [] @? "sync failed"
@ -1833,7 +1834,7 @@ test_export_import = intmpclonerepo $ do
git_annex "merge" ["foo/" ++ origbranch] @? "git annex merge failed" git_annex "merge" ["foo/" ++ origbranch] @? "git annex merge failed"
annexed_present_imported "import" annexed_present_imported "import"
nukeFile "import" removeWhenExistsWith removeLink "import"
writecontent "import" (content "newimport1") writecontent "import" (content "newimport1")
git_annex "add" ["import"] @? "add of import failed" git_annex "add" ["import"] @? "add of import failed"
commitchanges commitchanges
@ -1842,7 +1843,7 @@ test_export_import = intmpclonerepo $ do
-- verify that export refuses to overwrite modified file -- verify that export refuses to overwrite modified file
writedir "import" (content "newimport2") writedir "import" (content "newimport2")
nukeFile "import" removeWhenExistsWith removeLink "import"
writecontent "import" (content "newimport3") writecontent "import" (content "newimport3")
git_annex "add" ["import"] @? "add of import failed" git_annex "add" ["import"] @? "add of import failed"
commitchanges commitchanges
@ -1852,7 +1853,7 @@ test_export_import = intmpclonerepo $ do
-- resolving import conflict -- resolving import conflict
git_annex "import" [origbranch, "--from", "foo"] @? "import from dir failed" 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" 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") writecontent "import" (content "newimport3")
git_annex "add" ["import"] @? "add of import failed" git_annex "add" ["import"] @? "add of import failed"
commitchanges commitchanges

6
Types/LockCache.hs
View file

@ -10,7 +10,9 @@ module Types.LockCache (
LockHandle LockHandle
) where ) where
import qualified Data.Map as M
import Utility.LockPool (LockHandle) 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

2
Upgrade/V5.hs
View file

@ -150,7 +150,7 @@ upgradeDirectWorkTree = do
) )
writepointer f k = liftIO $ do writepointer f k = liftIO $ do
nukeFile f removeWhenExistsWith removeLink f
S.writeFile f (formatPointer k) S.writeFile f (formatPointer k)
{- Remove all direct mode bookkeeping files. -} {- Remove all direct mode bookkeeping files. -}

4
Upgrade/V5/Direct.hs
View file

@ -96,7 +96,7 @@ removeAssociatedFiles :: Key -> Annex ()
removeAssociatedFiles key = do removeAssociatedFiles key = do
mapping <- calcRepo $ gitAnnexMapping key mapping <- calcRepo $ gitAnnexMapping key
modifyContent mapping $ modifyContent mapping $
liftIO $ nukeFile mapping liftIO $ removeWhenExistsWith removeLink mapping
{- Checks if a file in the tree, associated with a key, has not been modified. {- 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 -> Annex ()
removeInodeCache key = withInodeCacheFile key $ \f -> removeInodeCache key = withInodeCacheFile key $ \f ->
modifyContent f $ modifyContent f $
liftIO $ nukeFile f liftIO $ removeWhenExistsWith removeLink f
withInodeCacheFile :: Key -> (FilePath -> Annex a) -> Annex a withInodeCacheFile :: Key -> (FilePath -> Annex a) -> Annex a
withInodeCacheFile key a = a =<< calcRepo (gitAnnexInodeCache key) withInodeCacheFile key a = a =<< calcRepo (gitAnnexInodeCache key)

9
Upgrade/V7.hs
View file

@ -33,7 +33,8 @@ upgrade automatic = do
-- new database is not populated. It will be automatically -- new database is not populated. It will be automatically
-- populated from the git-annex branch the next time it is used. -- populated from the git-annex branch the next time it is used.
removeOldDb gitAnnexContentIdentifierDbDirOld removeOldDb gitAnnexContentIdentifierDbDirOld
liftIO . nukeFile =<< fromRepo gitAnnexContentIdentifierLockOld liftIO . removeWhenExistsWith removeLink
=<< fromRepo gitAnnexContentIdentifierLockOld
-- The export databases are deleted here. The new databases -- The export databases are deleted here. The new databases
-- will be populated by the next thing that needs them, the same -- will be populated by the next thing that needs them, the same
@ -42,8 +43,10 @@ upgrade automatic = do
populateKeysDb populateKeysDb
removeOldDb gitAnnexKeysDbOld removeOldDb gitAnnexKeysDbOld
liftIO . nukeFile =<< fromRepo gitAnnexKeysDbIndexCacheOld liftIO . removeWhenExistsWith removeLink
liftIO . nukeFile =<< fromRepo gitAnnexKeysDbLockOld =<< fromRepo gitAnnexKeysDbIndexCacheOld
liftIO . removeWhenExistsWith removeLink
=<< fromRepo gitAnnexKeysDbLockOld
updateSmudgeFilter updateSmudgeFilter

16
Utility/Directory.hs
View file

@ -142,15 +142,9 @@ moveFile src dest = tryIO (rename src dest) >>= onrename
(Right s) -> return $ isDirectory s (Right s) -> return $ isDirectory s
#endif #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 - If an exception is thrown due to it not existing, it is ignored.
- cannot be removed, or if its a directory. -} -}
nukeFile :: FilePath -> IO () removeWhenExistsWith :: (a -> IO ()) -> a -> IO ()
nukeFile file = void $ tryWhenExists go removeWhenExistsWith f a = void $ tryWhenExists $ f a
where
#ifndef mingw32_HOST_OS
go = removeLink file
#else
go = removeFile file
#endif

2
Utility/LinuxMkLibs.hs
View file

@ -48,7 +48,7 @@ installLib installfile top lib = ifM (doesFileExist lib)
(toRawFilePath l) (toRawFilePath l)
target <- relPathDirToFile (toRawFilePath (takeDirectory f)) absl target <- relPathDirToFile (toRawFilePath (takeDirectory f)) absl
installfile top (fromRawFilePath absl) installfile top (fromRawFilePath absl)
nukeFile (top ++ f) removeWhenExistsWith removeLink (top ++ f)
createSymbolicLink (fromRawFilePath target) (inTop top f) createSymbolicLink (fromRawFilePath target) (inTop top f)
checksymlink (fromRawFilePath absl) checksymlink (fromRawFilePath absl)

70
Utility/LockFile/PidLock.hs
View file

@ -5,6 +5,8 @@
- License: BSD-2-clause - License: BSD-2-clause
-} -}
{-# LANGUAGE OverloadedStrings #-}
module Utility.LockFile.PidLock ( module Utility.LockFile.PidLock (
LockHandle, LockHandle,
tryLock, tryLock,
@ -34,12 +36,13 @@ import Utility.Env.Set
import qualified Utility.LockFile.Posix as Posix import qualified Utility.LockFile.Posix as Posix
import System.IO import System.IO
import System.Posix.IO
import System.Posix.Types import System.Posix.Types
import System.Posix.Files import System.Posix.IO.ByteString
import System.Posix.Files.ByteString
import System.Posix.Process import System.Posix.Process
import Control.Monad import Control.Monad
import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.IO.Class (liftIO, MonadIO)
import qualified System.FilePath.ByteString as P
import Data.Maybe import Data.Maybe
import Data.List import Data.List
import Network.BSD import Network.BSD
@ -47,7 +50,7 @@ import System.FilePath
import Control.Applicative import Control.Applicative
import Prelude import Prelude
type LockFile = FilePath type LockFile = RawFilePath
data LockHandle data LockHandle
= LockHandle LockFile FileStatus SideLockHandle = LockHandle LockFile FileStatus SideLockHandle
@ -67,7 +70,8 @@ mkPidLock = PidLock
<*> getHostName <*> getHostName
readPidLock :: LockFile -> IO (Maybe PidLock) 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. -- To avoid races when taking over a stale pid lock, a side lock is used.
-- This is a regular posix exclusive lock. -- 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 -- 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 -- deleted, and so will be able to immediately see that it's taken
-- a stale lock. -- a stale lock.
_ <- tryIO $ removeFile f _ <- tryIO $ removeFile (fromRawFilePath f)
Posix.dropLock h Posix.dropLock h
-- The side lock is put in /dev/shm. This will work on most any -- 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. -- locks. /tmp is used as a fallback.
sideLockFile :: LockFile -> IO LockFile sideLockFile :: LockFile -> IO LockFile
sideLockFile lockfile = do sideLockFile lockfile = do
f <- fromRawFilePath <$> absPath (toRawFilePath lockfile) f <- fromRawFilePath <$> absPath lockfile
let base = intercalate "_" (splitDirectories (makeRelative "/" f)) let base = intercalate "_" (splitDirectories (makeRelative "/" f))
let shortbase = reverse $ take 32 $ reverse base let shortbase = reverse $ take 32 $ reverse base
let md5sum = if base == shortbase let md5sum = if base == shortbase
then "" then ""
else show (md5 (encodeBL base)) else toRawFilePath $ show (md5 (encodeBL base))
dir <- ifM (doesDirectoryExist "/dev/shm") dir <- ifM (doesDirectoryExist "/dev/shm")
( return "/dev/shm" ( return "/dev/shm"
, return "/tmp" , 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. -- | 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. -- "PIDLOCK_lockfile" environment variable, does not block either.
tryLock :: LockFile -> IO (Maybe LockHandle) tryLock :: LockFile -> IO (Maybe LockHandle)
tryLock lockfile = do tryLock lockfile = do
abslockfile <- fromRawFilePath <$> absPath (toRawFilePath lockfile) abslockfile <- absPath lockfile
lockenv <- pidLockEnv abslockfile lockenv <- pidLockEnv abslockfile
getEnv lockenv >>= \case getEnv lockenv >>= \case
Nothing -> trySideLock lockfile (go abslockfile) Nothing -> trySideLock lockfile (go abslockfile)
_ -> return (Just ParentLocked) _ -> return (Just ParentLocked)
where where
go abslockfile sidelock = do go abslockfile sidelock = do
(tmp, h) <- openTempFile (takeDirectory abslockfile) "locktmp" let abslockfile' = fromRawFilePath abslockfile
setFileMode tmp (combineModes readModes) (tmp, h) <- openTempFile (takeDirectory abslockfile') "locktmp"
let tmp' = toRawFilePath tmp
setFileMode tmp' (combineModes readModes)
hPutStr h . show =<< mkPidLock hPutStr h . show =<< mkPidLock
hClose h hClose h
let failedlock st = do let failedlock st = do
dropLock $ LockHandle tmp st sidelock dropLock $ LockHandle tmp' st sidelock
nukeFile tmp removeWhenExistsWith removeLink tmp'
return Nothing return Nothing
let tooklock st = return $ Just $ LockHandle abslockfile st sidelock let tooklock st = return $ Just $ LockHandle abslockfile st sidelock
ifM (linkToLock sidelock tmp abslockfile) ifM (linkToLock sidelock tmp' abslockfile)
( do ( do
nukeFile tmp removeWhenExistsWith removeLink tmp'
-- May not have made a hard link, so stat -- May not have made a hard link, so stat
-- the lockfile -- the lockfile
lckst <- getFileStatus abslockfile lckst <- getFileStatus abslockfile
@ -157,7 +163,7 @@ tryLock lockfile = do
, do , do
v <- readPidLock abslockfile v <- readPidLock abslockfile
hn <- getHostName hn <- getHostName
tmpst <- getFileStatus tmp tmpst <- getFileStatus tmp'
case v of case v of
Just pl | isJust sidelock && hn == lockingHost pl -> do Just pl | isJust sidelock && hn == lockingHost pl -> do
-- Since we have the sidelock, -- Since we have the sidelock,
@ -165,7 +171,7 @@ tryLock lockfile = do
-- the pidlock was taken on, -- the pidlock was taken on,
-- we know that the pidlock is -- we know that the pidlock is
-- stale, and can take it over. -- stale, and can take it over.
rename tmp abslockfile rename tmp' abslockfile
tooklock tmpst tooklock tmpst
_ -> failedlock tmpst _ -> failedlock tmpst
) )
@ -180,12 +186,12 @@ tryLock lockfile = do
-- --
-- However, not all filesystems support hard links. So, first probe -- However, not all filesystems support hard links. So, first probe
-- to see if they are supported. If not, use open with O_EXCL. -- 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 Nothing _ _ = return False
linkToLock (Just _) src dest = do linkToLock (Just _) src dest = do
let probe = src ++ ".lnk" let probe = src <> ".lnk"
v <- tryIO $ createLink src probe v <- tryIO $ createLink src probe
nukeFile probe removeWhenExistsWith removeLink probe
case v of case v of
Right _ -> do Right _ -> do
_ <- tryIO $ createLink src dest _ <- tryIO $ createLink src dest
@ -200,7 +206,8 @@ linkToLock (Just _) src dest = do
(defaultFileFlags {exclusive = True}) (defaultFileFlags {exclusive = True})
fdToHandle fd fdToHandle fd
let cleanup = hClose 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 return True
where where
checklinked = do checklinked = do
@ -228,16 +235,17 @@ linkToLock (Just _) src dest = do
-- We can detect this insanity by getting the directory contents after -- 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, -- making the link, and checking to see if 2 copies of the dest file,
-- with the SAME FILENAME exist. -- with the SAME FILENAME exist.
checkInsaneLustre :: FilePath -> IO Bool checkInsaneLustre :: RawFilePath -> IO Bool
checkInsaneLustre dest = do checkInsaneLustre dest = do
fs <- dirContents (takeDirectory dest) let dest' = fromRawFilePath dest
case length (filter (== dest) fs) of fs <- dirContents (takeDirectory dest')
case length (filter (== dest') fs) of
1 -> return False -- whew! 1 -> return False -- whew!
0 -> return True -- wtf? 0 -> return True -- wtf?
_ -> do _ -> do
-- Try to clean up the extra copy we made -- Try to clean up the extra copy we made
-- that has the same name. Egads. -- that has the same name. Egads.
_ <- tryIO $ removeFile dest _ <- tryIO $ removeFile dest'
return True return True
-- | Waits as necessary to take a lock. -- | Waits as necessary to take a lock.
@ -253,20 +261,20 @@ waitLock (Seconds timeout) lockfile displaymessage = go timeout
| n > 0 = liftIO (tryLock lockfile) >>= \case | n > 0 = liftIO (tryLock lockfile) >>= \case
Nothing -> do Nothing -> do
when (n == pred timeout) $ 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) liftIO $ threadDelaySeconds (Seconds 1)
go (pred n) go (pred n)
Just lckh -> return lckh Just lckh -> return lckh
| otherwise = do | otherwise = do
displaymessage $ show timeout ++ " second timeout exceeded while 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 " ++ lockfile giveup $ "Gave up waiting for pid lock file " ++ fromRawFilePath lockfile
dropLock :: LockHandle -> IO () dropLock :: LockHandle -> IO ()
dropLock (LockHandle lockfile _ sidelock) = do dropLock (LockHandle lockfile _ sidelock) = do
-- Drop side lock first, at which point the pid lock will be -- Drop side lock first, at which point the pid lock will be
-- considered stale. -- considered stale.
dropSideLock sidelock dropSideLock sidelock
nukeFile lockfile removeWhenExistsWith removeLink lockfile
dropLock ParentLocked = return () dropLock ParentLocked = return ()
getLockStatus :: LockFile -> IO LockStatus getLockStatus :: LockFile -> IO LockStatus
@ -297,9 +305,9 @@ checkSaneLock _ ParentLocked = return True
-- The parent process should keep running as long as the child -- The parent process should keep running as long as the child
-- process is running, since the child inherits the environment and will -- process is running, since the child inherits the environment and will
-- not see unsetLockEnv. -- not see unsetLockEnv.
pidLockEnv :: FilePath -> IO String pidLockEnv :: RawFilePath -> IO String
pidLockEnv lockfile = do pidLockEnv lockfile = do
abslockfile <- fromRawFilePath <$> absPath (toRawFilePath lockfile) abslockfile <- fromRawFilePath <$> absPath lockfile
return $ "PIDLOCK_" ++ filter legalInEnvVar abslockfile return $ "PIDLOCK_" ++ filter legalInEnvVar abslockfile
pidLockEnvValue :: String pidLockEnvValue :: String

7
Utility/LockFile/Posix.hs
View file

@ -25,10 +25,13 @@ import Utility.Applicative
import Utility.LockFile.LockStatus import Utility.LockFile.LockStatus
import System.IO 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 import Data.Maybe
type LockFile = FilePath type LockFile = RawFilePath
newtype LockHandle = LockHandle Fd newtype LockHandle = LockHandle Fd

11
Utility/LockFile/Windows.hs
View file

@ -16,15 +16,18 @@ module Utility.LockFile.Windows (
import System.Win32.Types import System.Win32.Types
import System.Win32.File import System.Win32.File
import Control.Concurrent import Control.Concurrent
import System.FilePath.ByteString (RawFilePath)
type LockFile = FilePath import Utility.FileSystemEncoding
type LockFile = RawFilePath
type LockHandle = HANDLE type LockHandle = HANDLE
{- Tries to lock a file with a shared lock, which allows other processes to {- 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. -} - also lock it shared. Fails if the file is exclusively locked. -}
lockShared :: LockFile -> IO (Maybe LockHandle) 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 {- Tries to take an exclusive lock on a file. Fails if another process has
- a shared or exclusive lock. - 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 - read or write by any other process. So for advisory locking of a file's
- content, a separate LockFile should be used. -} - content, a separate LockFile should be used. -}
lockExclusive :: LockFile -> IO (Maybe LockHandle) 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 {- Windows considers just opening a file enough to lock it. This will
- create the LockFile if it does not already exist. - 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 -> LockFile -> IO (Maybe LockHandle)
openLock sharemode f = do openLock sharemode f = do
h <- withTString f $ \c_f -> h <- withTString (fromRawFilePath f) $ \c_f ->
c_CreateFile c_f gENERIC_READ sharemode security_attributes c_CreateFile c_f gENERIC_READ sharemode security_attributes
oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL (maybePtr Nothing) oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL (maybePtr Nothing)
return $ if h == iNVALID_HANDLE_VALUE return $ if h == iNVALID_HANDLE_VALUE

3
Utility/LockPool/STM.hs
View file

@ -22,6 +22,7 @@ module Utility.LockPool.STM (
import Utility.Monad import Utility.Monad
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import System.FilePath.ByteString (RawFilePath)
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Exception import Control.Exception
@ -29,7 +30,7 @@ import Control.Monad
import Control.Applicative import Control.Applicative
import Prelude import Prelude
type LockFile = FilePath type LockFile = RawFilePath
data LockMode = LockExclusive | LockShared data LockMode = LockExclusive | LockShared
deriving (Eq) deriving (Eq)

10
Utility/RawFilePath.hs
View file

@ -18,6 +18,8 @@ module Utility.RawFilePath (
RawFilePath, RawFilePath,
readSymbolicLink, readSymbolicLink,
createSymbolicLink, createSymbolicLink,
createLink,
removeLink,
getFileStatus, getFileStatus,
getSymbolicLinkStatus, getSymbolicLinkStatus,
doesPathExist, doesPathExist,
@ -56,6 +58,14 @@ createSymbolicLink a b = P.createSymbolicLink
(fromRawFilePath a) (fromRawFilePath a)
(fromRawFilePath b) (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 :: RawFilePath -> IO FileStatus
getFileStatus = P.getFileStatus . fromRawFilePath getFileStatus = P.getFileStatus . fromRawFilePath