3 files changed, 65 insertions, 37 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
+
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 <$>