diff options
Diffstat (limited to 'Assistant/Threads/SanityChecker.hs')
| -rw-r--r-- | Assistant/Threads/SanityChecker.hs | 62 |
1 files changed, 61 insertions, 1 deletions
diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index 64fbc2fb6..7d6057924 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -1,11 +1,12 @@ {- git-annex assistant sanity checker - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012, 2013 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} module Assistant.Threads.SanityChecker ( + sanityCheckerStartupThread, sanityCheckerDailyThread, sanityCheckerHourlyThread ) where @@ -20,10 +21,20 @@ import Utility.ThreadScheduler import qualified Assistant.Threads.Watcher as Watcher import Utility.LogFile import Utility.Batch +import Utility.NotificationBroadcaster import Config +import qualified Git +import qualified Utility.Lsof as Lsof import Data.Time.Clock.POSIX +{- This thread runs once at startup, and most other threads wait for it + - to finish. (However, the webapp thread does not, to prevent the UI + - being nonresponsive.) -} +sanityCheckerStartupThread :: NamedThread +sanityCheckerStartupThread = namedThreadUnchecked "SanityCheckerStartup" $ + startupCheck + {- This thread wakes up hourly for inxepensive frequent sanity checks. -} sanityCheckerHourlyThread :: NamedThread sanityCheckerHourlyThread = namedThread "SanityCheckerHourly" $ forever $ do @@ -69,6 +80,14 @@ waitForNextCheck = do oneDay - truncate (now - lastcheck) | otherwise = oneDay +startupCheck :: Assistant () +startupCheck = do + checkStaleGitLocks + + {- Notify other threads that the startup sanity check is done. -} + status <- getDaemonStatus + liftIO $ sendNotification $ startupSanityCheckNotifier status + {- It's important to stay out of the Annex monad as much as possible while - running potentially expensive parts of this check, since remaining in it - will block the watcher. -} @@ -128,6 +147,46 @@ checkLogSize n = do where filesize f = fromIntegral . fileSize <$> liftIO (getFileStatus f) +{- Detect when a git lock file exists and has no git process currently + - writing to it. This strongly suggests it is a stale lock file. + - + - However, this could be on a network filesystem. Which is not very safe + - anyway (the assistant relies on being able to check when files have + - no writers to know when to commit them). Just in case, when the lock + - file appears stale, we delay for one minute, and check its size. If + - the size changed, delay for another minute, and so on. This will at + - least work to detect is another machine is writing out a new index + - file, since git does so by writing the new content to index.lock. + -} +checkStaleGitLocks :: Assistant () +checkStaleGitLocks = do + lockfiles <- filter (not . isInfixOf "gc.pid") + . filter (".lock" `isSuffixOf`) + <$> (liftIO . dirContentsRecursiveSkipping (annexDir `isInfixOf`) + =<< liftAnnex (fromRepo Git.localGitDir)) + checkStaleLocks lockfiles +checkStaleLocks :: [FilePath] -> Assistant () +checkStaleLocks lockfiles = go =<< getsizes + where + getsize lf = catchMaybeIO $ + (\s -> (lf, fileSize s)) <$> getFileStatus lf + getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles + go [] = return () + go l = ifM (liftIO $ null <$> Lsof.query ("--" : map fst l)) + ( do + waitforit "to check stale git lock file" + l' <- getsizes + if l' == l + then liftIO $ mapM_ nukeFile (map fst l) + else go l' + , do + waitforit "for git lock file writer" + go =<< getsizes + ) + waitforit why = do + notice ["Waiting for 60 seconds", why] + liftIO $ threadDelaySeconds $ Seconds 60 + oneMegabyte :: Int oneMegabyte = 1000000 @@ -136,3 +195,4 @@ oneHour = 60 * 60 oneDay :: Int oneDay = 24 * oneHour + |