assistant: Clean up stale tmp files on startup.

This commit was sponsored by Melissa Binde.

1 files changed, 56 insertions, 0 deletions

diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs
index d7a71d477..ba141698d 100644
--- a/Assistant/Threads/SanityChecker.hs
+++ b/Assistant/Threads/SanityChecker.hs
@@ -46,6 +46,7 @@ import Assistant.WebApp.Types
 #ifndef mingw32_HOST_OS
 import Utility.LogFile
 #endif
+import Types.Key (keyBackendName)
 
 import Data.Time.Clock.POSIX
 import qualified Data.Text as T
@@ -82,6 +83,10 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta
 	{- Fix up ssh remotes set up by past versions of the assistant. -}
 	liftIO $ fixUpSshRemotes
 
+	{- Clean up old temp files. -}
+	liftAnnex cleanOldTmpMisc
+	liftAnnex cleanReallyOldTmp
+
 	{- If there's a startup delay, it's done here. -}
 	liftIO $ maybe noop (threadDelaySeconds . Seconds . fromIntegral . durationSeconds) startupdelay
 
@@ -258,3 +263,54 @@ checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGit
 #else
 		debug [show $ renderTense Past msg]
 #endif
+
+{- Files may be left in misctmp by eg, an interrupted add of files
+ - by the assistant, which hard links files to there as part of lockdown
+ - checks. Delete these files if they're more than a day old.
+ -
+ - Note that this is not safe to run after the Watcher starts up, since it
+ - will create such files, and due to hard linking they may have old
+ - mtimes. So, this should only be called from the
+ - sanityCheckerStartupThread, which runs before the Watcher starts up.
+ -
+ - Also, if a git-annex add is being run at the same time the assistant
+ - starts up, its tmp files could be deleted. However, the watcher will
+ - come along and add everything once it starts up anyway, so at worst
+ - this would make the git-annex add fail unexpectedly.
+ -}
+cleanOldTmpMisc :: Annex ()
+cleanOldTmpMisc = do
+	now <- liftIO getPOSIXTime
+	let oldenough = now - (60 * 60 * 24)
+	tmp <- fromRepo gitAnnexTmpMiscDir
+	liftIO $ mapM_ (cleanOld (<= oldenough)) =<< dirContentsRecursive tmp
+
+{- While .git/annex/tmp is now only used for storing partially transferred
+ - objects, older versions of git-annex used it for misctemp. Clean up any
+ - files that might be left from that, by looking for files whose names
+ - cannot be the key of an annexed object. Only delete files older than
+ - 1 week old.
+ -
+ - Also, some remotes such as rsync may use this temp directory for storing
+ - eg, encrypted objects that are being transferred. So, delete old
+ - objects that use a GPGHMAC backend.
+ -}
+cleanReallyOldTmp :: Annex ()
+cleanReallyOldTmp = do
+	now <- liftIO getPOSIXTime
+	let oldenough = now - (60 * 60 * 24 * 7)
+	tmp <- fromRepo gitAnnexTmpObjectDir
+	liftIO $ mapM_ (cleanjunk (<= oldenough)) =<< dirContentsRecursive tmp
+  where
+	cleanjunk check f = case fileKey (takeFileName f) of
+		Nothing -> cleanOld check f
+		Just k
+			| "GPGHMAC" `isPrefixOf` keyBackendName k ->
+				cleanOld check f
+			| otherwise -> noop
+
+cleanOld :: (POSIXTime -> Bool) -> FilePath -> IO ()
+cleanOld check f = do
+	mtime <- realToFrac . modificationTime <$> getFileStatus f
+	when (check mtime) $
+		nukeFile f