a64fca92f6
Need to create the directory after the lock is held, not before. The other racing process would need to shut down at just the wrong time, running cleanupOtherTmp. This commit was sponsored by Boyd Stephen Smith Jr. on Patreon.
57 lines
1.8 KiB
Haskell
57 lines
1.8 KiB
Haskell
{- git-annex tmp files
|
|
-
|
|
- Copyright 2019 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Annex.Tmp where
|
|
|
|
import Common
|
|
import Annex
|
|
import Annex.Locations
|
|
import Annex.LockFile
|
|
import Annex.Perms
|
|
import Types.CleanupActions
|
|
|
|
import Data.Time.Clock.POSIX
|
|
|
|
-- | For creation of tmp files, other than for key's contents.
|
|
--
|
|
-- The action should normally clean up whatever files it writes to the temp
|
|
-- directory that is passed to it. However, once the action is done,
|
|
-- any files left in that directory may be cleaned up by another process at
|
|
-- any time.
|
|
withOtherTmp :: (FilePath -> Annex a) -> Annex a
|
|
withOtherTmp a = do
|
|
addCleanup OtherTmpCleanup cleanupOtherTmp
|
|
tmpdir <- fromRepo gitAnnexTmpOtherDir
|
|
tmplck <- fromRepo gitAnnexTmpOtherLock
|
|
withSharedLock (const tmplck) $ do
|
|
void $ createAnnexDirectory tmpdir
|
|
a tmpdir
|
|
|
|
-- | Cleans up any tmp files that were left by a previous
|
|
-- git-annex process that got interrupted or failed to clean up after
|
|
-- itself for some other reason.
|
|
--
|
|
-- Does not do anything if withOtherTmp is running.
|
|
cleanupOtherTmp :: Annex ()
|
|
cleanupOtherTmp = do
|
|
tmplck <- fromRepo gitAnnexTmpOtherLock
|
|
void $ tryIO $ tryExclusiveLock (const tmplck) $ do
|
|
tmpdir <- fromRepo gitAnnexTmpOtherDir
|
|
void $ liftIO $ tryIO $ removeDirectoryRecursive tmpdir
|
|
-- This is only to clean up cruft left by old versions of
|
|
-- git-annex; it can be removed eventually.
|
|
oldtmp <- fromRepo gitAnnexTmpOtherDirOld
|
|
liftIO $ mapM_ cleanold =<< dirContentsRecursive oldtmp
|
|
liftIO $ void $ tryIO $ removeDirectory oldtmp -- when empty
|
|
where
|
|
cleanold f = do
|
|
now <- liftIO getPOSIXTime
|
|
let oldenough = now - (60 * 60 * 24 * 7)
|
|
catchMaybeIO (modificationTime <$> getSymbolicLinkStatus f) >>= \case
|
|
Just mtime | realToFrac mtime <= oldenough ->
|
|
void $ tryIO $ nukeFile f
|
|
_ -> return ()
|