diff options
Diffstat (limited to 'Assistant')
| -rw-r--r-- | Assistant/NamedThread.hs | 25 | ||||
| -rw-r--r-- | Assistant/Threads/SanityChecker.hs | 62 | ||||
| -rw-r--r-- | Assistant/Threads/Watcher.hs | 35 | ||||
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 5 | ||||
| -rw-r--r-- | Assistant/Types/DaemonStatus.hs | 6 | ||||
| -rw-r--r-- | Assistant/Types/NamedThread.hs | 8 |
6 files changed, 93 insertions, 48 deletions
diff --git a/Assistant/NamedThread.hs b/Assistant/NamedThread.hs index edebe830f..f29f0cf36 100644 --- a/Assistant/NamedThread.hs +++ b/Assistant/NamedThread.hs @@ -16,6 +16,7 @@ import Assistant.Types.DaemonStatus import Assistant.Types.UrlRenderer import Assistant.DaemonStatus import Assistant.Monad +import Utility.NotificationBroadcaster import Control.Concurrent import Control.Concurrent.Async @@ -34,7 +35,7 @@ import qualified Data.Text as T - Named threads are run by a management thread, so if they crash - an alert is displayed, allowing the thread to be restarted. -} startNamedThread :: UrlRenderer -> NamedThread -> Assistant () -startNamedThread urlrenderer namedthread@(NamedThread name a) = do +startNamedThread urlrenderer (NamedThread afterstartupsanitycheck name a) = do m <- startedThreads <$> getDaemonStatus case M.lookup name m of Nothing -> start @@ -44,14 +45,24 @@ startNamedThread urlrenderer namedthread@(NamedThread name a) = do Right Nothing -> noop _ -> start where - start = do + start + | afterstartupsanitycheck = do + status <- getDaemonStatus + h <- liftIO $ newNotificationHandle False $ + startupSanityCheckNotifier status + startwith $ runmanaged $ + liftIO $ waitNotification h + | otherwise = startwith $ runmanaged noop + startwith runner = do d <- getAssistant id - aid <- liftIO $ runmanaged $ d { threadName = name } - restart <- asIO $ startNamedThread urlrenderer namedthread + aid <- liftIO $ runner $ d { threadName = name } + restart <- asIO $ startNamedThread urlrenderer (NamedThread False name a) modifyDaemonStatus_ $ \s -> s { startedThreads = M.insertWith' const name (aid, restart) (startedThreads s) } - runmanaged d = do - aid <- async $ runAssistant d a + runmanaged first d = do + aid <- async $ runAssistant d $ do + void first + a void $ forkIO $ manager d aid return aid manager d aid = do @@ -75,7 +86,7 @@ startNamedThread urlrenderer namedthread@(NamedThread name a) = do #endif namedThreadId :: NamedThread -> Assistant (Maybe ThreadId) -namedThreadId (NamedThread name _) = do +namedThreadId (NamedThread _ name _) = do m <- startedThreads <$> getDaemonStatus return $ asyncThreadId . fst <$> M.lookup name m 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 + diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index 9b9321014..c10d03eeb 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -122,7 +122,6 @@ waitFor sig next = do {- Initial scartup scan. The action should return once the scan is complete. -} startupScan :: IO a -> Assistant a startupScan scanner = do - checkStaleIndexLock liftAnnex $ showAction "scanning" alertWhile' startupScanAlert $ do r <- liftIO scanner @@ -143,40 +142,6 @@ startupScan scanner = do return (True, r) -{- Detect when .git/index.lock exists and has no git process currently - - writing to it. This strongly suggests it is a stale lock file, because - - git writes the new index to index.lock and renames it over top. - - - - 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 file - - appears stale, we delay for one minute, and check its size. If the size - - changed, delay for another minute, and so on. - -} -checkStaleIndexLock :: Assistant () -checkStaleIndexLock = do - dir <- liftAnnex $ fromRepo Git.localGitDir - checkStale $ dir </> "index.lock" -checkStale :: FilePath -> Assistant () -checkStale indexlock = go =<< getsize - where - getsize = liftIO $ catchMaybeIO $ fileSize <$> getFileStatus indexlock - go Nothing = return () - go oldsize = ifM (liftIO $ null <$> Lsof.query ["--", indexlock]) - ( do - waitforit "to check stale" - size <- getsize - if size == oldsize - then liftIO $ nukeFile indexlock - else go size - , do - waitforit "for writer on" - go =<< getsize - ) - waitforit why = do - notice ["Waiting for 60 seconds", why, indexlock] - liftIO $ threadDelaySeconds $ Seconds 60 - {- Hardcoded ignores, passed to the DirWatcher so it can avoid looking - at the entire .git directory. Does not include .gitignores. -} ignored :: FilePath -> Bool diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 0fb038b6a..4620b0387 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -83,7 +83,10 @@ webAppThread assistantdata urlrenderer noannex listenhost postfirstrun onstartup urlfile <- runThreadState st $ fromRepo gitAnnexUrlFile go addr webapp htmlshim (Just urlfile) where - thread = namedThread "WebApp" + -- The webapp thread does not wait for the startupSanityCheckThread + -- to finish, so that the user interface remains responsive while + -- that's going on. + thread = namedThreadUnchecked "WebApp" getreldir | noannex = return Nothing | otherwise = Just <$> diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs index 17e535b6d..65190fe40 100644 --- a/Assistant/Types/DaemonStatus.hs +++ b/Assistant/Types/DaemonStatus.hs @@ -31,9 +31,9 @@ data DaemonStatus = DaemonStatus , scanComplete :: Bool -- Time when a previous process of the daemon was running ok , lastRunning :: Maybe POSIXTime - -- True when the sanity checker is running + -- True when the daily sanity checker is running , sanityCheckRunning :: Bool - -- Last time the sanity checker ran + -- Last time the daily sanity checker ran , lastSanityCheck :: Maybe POSIXTime -- True when a scan for file transfers is running , transferScanRunning :: Bool @@ -62,6 +62,7 @@ data DaemonStatus = DaemonStatus , alertNotifier :: NotificationBroadcaster -- Broadcasts notifications when the syncRemotes change , syncRemotesNotifier :: NotificationBroadcaster + , startupSanityCheckNotifier :: NotificationBroadcaster -- When the XMPP client is connected, this will contain the XMPP -- address. , xmppClientID :: Maybe ClientID @@ -93,4 +94,5 @@ newDaemonStatus = DaemonStatus <*> newNotificationBroadcaster <*> newNotificationBroadcaster <*> newNotificationBroadcaster + <*> newNotificationBroadcaster <*> pure Nothing diff --git a/Assistant/Types/NamedThread.hs b/Assistant/Types/NamedThread.hs index a65edc20d..5dd1364ad 100644 --- a/Assistant/Types/NamedThread.hs +++ b/Assistant/Types/NamedThread.hs @@ -11,7 +11,11 @@ import Assistant.Monad import Assistant.Types.ThreadName {- Information about a named thread that can be run. -} -data NamedThread = NamedThread ThreadName (Assistant ()) +data NamedThread = NamedThread Bool ThreadName (Assistant ()) namedThread :: String -> Assistant () -> NamedThread -namedThread = NamedThread . ThreadName +namedThread = NamedThread True . ThreadName + +{- A named thread that can start running before the startup sanity check. -} +namedThreadUnchecked :: String -> Assistant () -> NamedThread +namedThreadUnchecked = NamedThread False . ThreadName |