1 files changed, 98 insertions, 0 deletions
diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs
new file mode 100644
index 000000000..a7c2189d8
--- /dev/null
+++ b/Assistant/Threads/SanityChecker.hs
@@ -0,0 +1,98 @@
+{- git-annex assistant sanity checker
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Threads.SanityChecker (
+	sanityCheckerThread
+) where
+
+import Assistant.Common
+import Assistant.DaemonStatus
+import Assistant.ThreadedMonad
+import Assistant.Changes
+import Assistant.Alert
+import Assistant.TransferQueue
+import qualified Git.LsFiles
+import Utility.ThreadScheduler
+import qualified Assistant.Threads.Watcher as Watcher
+
+import Data.Time.Clock.POSIX
+
+thisThread :: ThreadName
+thisThread = "SanityChecker"
+
+{- This thread wakes up occasionally to make sure the tree is in good shape. -}
+sanityCheckerThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO ()
+sanityCheckerThread st dstatus transferqueue changechan = forever $ do
+	waitForNextCheck dstatus
+
+	debug thisThread ["starting sanity check"]
+
+	void $ alertWhile dstatus sanityCheckAlert go
+	
+	debug thisThread ["sanity check complete"]
+	where
+		go = do
+			modifyDaemonStatus_ dstatus $ \s -> s
+				{ sanityCheckRunning = True }
+
+			now <- getPOSIXTime -- before check started
+			r <- catchIO (check st dstatus transferqueue changechan)
+				$ \e -> do
+					runThreadState st $ warning $ show e
+					return False
+
+			modifyDaemonStatus_ dstatus $ \s -> s
+				{ sanityCheckRunning = False
+				, lastSanityCheck = Just now
+				}
+
+			return r
+
+{- Only run one check per day, from the time of the last check. -}
+waitForNextCheck :: DaemonStatusHandle -> IO ()
+waitForNextCheck dstatus = do
+	v <- lastSanityCheck <$> getDaemonStatus dstatus
+	now <- getPOSIXTime
+	threadDelaySeconds $ Seconds $ calcdelay now v
+	where
+		calcdelay _ Nothing = oneDay
+		calcdelay now (Just lastcheck)
+			| lastcheck < now = max oneDay $
+				oneDay - truncate (now - lastcheck)
+			| otherwise = oneDay
+
+oneDay :: Int
+oneDay = 24 * 60 * 60
+
+{- 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. -}
+check :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO Bool
+check st dstatus transferqueue changechan = do
+	g <- runThreadState st $ fromRepo id
+	-- Find old unstaged symlinks, and add them to git.
+	unstaged <- Git.LsFiles.notInRepo False ["."] g
+	now <- getPOSIXTime
+	forM_ unstaged $ \file -> do
+		ms <- catchMaybeIO $ getSymbolicLinkStatus file
+		case ms of
+			Just s	| toonew (statusChangeTime s) now -> noop
+				| isSymbolicLink s ->
+					addsymlink file ms
+			_ -> noop
+	return True
+	where
+		toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime)
+		slop = fromIntegral tenMinutes
+		insanity msg = do
+			runThreadState st $ warning msg
+			void $ addAlert dstatus $ sanityCheckFixAlert msg
+		addsymlink file s = do
+			Watcher.runHandler thisThread st dstatus
+				transferqueue changechan
+				Watcher.onAddSymlink file s
+			insanity $ "found unstaged symlink: " ++ file