add sanity checker thread

Currently wakes up once a day, and does nothing. :)

Assistant.hs

@@ -45,6 +45,7 @@ import Assistant.ThreadedMonad
 import Assistant.DaemonStatus
 import Assistant.Watcher
 import Assistant.Committer
+import Assistant.SanityChecker
 import qualified Utility.Daemon
 import Utility.LogFile
 
@@ -71,6 +72,7 @@ startDaemon foreground
 				-- is taking place.
 				_ <- forkIO $ commitThread st changechan
 				_ <- forkIO $ daemonStatusThread st dstatus
+				_ <- forkIO $ sanityCheckerThread st dstatus
 				watchThread st dstatus changechan
 
 stopDaemon :: Annex ()

Assistant/Committer.hs

@@ -9,8 +9,8 @@ import Common.Annex
 import Assistant.ThreadedMonad
 import qualified Annex.Queue
 import qualified Git.Command
+import Utility.ThreadScheduler
 
-import Control.Concurrent
 import Control.Concurrent.STM
 import Data.Time.Clock
 
@@ -59,9 +59,8 @@ refillChanges chan cs = runChangeChan $ mapM_ (writeTChan chan) cs
 
 {- This thread makes git commits at appropriate times. -}
 commitThread :: ThreadState -> ChangeChan -> IO ()
-commitThread st changechan = forever $ do
+commitThread st changechan = runEvery (Seconds 1) $ do
-	-- First, a simple rate limiter.
+	-- We already waited one second as a simple rate limiter.
-	threadDelay oneSecond
 	-- Next, wait until at least one change has been made.
 	cs <- getChanges changechan
 	-- Now see if now's a good time to commit.
@@ -69,8 +68,6 @@ commitThread st changechan = forever $ do
 	if shouldCommit time cs
 		then void $ tryIO $ runThreadState st commitStaged
 		else refillChanges changechan cs
-	where
-		oneSecond = 1000000 -- microseconds
 
 commitStaged :: Annex ()
 commitStaged = do

Assistant/DaemonStatus.hs

@@ -6,8 +6,9 @@
 module Assistant.DaemonStatus where
 
 import Common.Annex
-import Utility.TempFile
 import Assistant.ThreadedMonad
+import Utility.ThreadScheduler
+import Utility.TempFile
 
 import Control.Concurrent
 import System.Posix.Types
@@ -20,6 +21,10 @@ 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
+	, sanityCheckRunning :: Bool
+	-- Last time the sanity checker ran
+	, lastSanityCheck :: Maybe POSIXTime
 	}
 	deriving (Show)
 
@@ -29,6 +34,8 @@ newDaemonStatus :: DaemonStatus
 newDaemonStatus = DaemonStatus
 	{ scanComplete = False
 	, lastRunning = Nothing
+	, sanityCheckRunning = False
+	, lastSanityCheck = Nothing
 	}
 
 getDaemonStatus :: DaemonStatusHandle -> Annex DaemonStatus
@@ -44,21 +51,21 @@ startDaemonStatus = do
 	file <- fromRepo gitAnnexDaemonStatusFile
 	status <- liftIO $
 		catchDefaultIO (readDaemonStatusFile file) newDaemonStatus
-	liftIO $ newMVar status { scanComplete = False }
+	liftIO $ newMVar status
+		{ scanComplete = False
+		, sanityCheckRunning = False
+		}
 
 {- This thread wakes up periodically and writes the daemon status to disk. -}
 daemonStatusThread :: ThreadState -> DaemonStatusHandle -> IO ()
 daemonStatusThread st handle = do
 	checkpoint
-	forever $ do
+	runEvery (Seconds tenMinutes) checkpoint
-		threadDelay (tenMinutes * oneSecond)
-		checkpoint
 	where
 		checkpoint = runThreadState st $ do
 			file <- fromRepo gitAnnexDaemonStatusFile
 			status <- getDaemonStatus handle
 			liftIO $ writeDaemonStatusFile file status
-		oneSecond = 1000000 -- microseconds
 
 {- Don't just dump out the structure, because it will change over time,
  - and parts of it are not relevant. -}
@@ -69,6 +76,8 @@ writeDaemonStatusFile file status =
 		serialized now = unlines
 			[ "lastRunning:" ++ show now
 			, "scanComplete:" ++ show (scanComplete status)
+			, "sanityCheckRunning:" ++ show (sanityCheckRunning status)
+			, "lastSanityCheck:" ++ show (lastSanityCheck status)
 			]
 
 readDaemonStatusFile :: FilePath -> IO DaemonStatus
@@ -80,6 +89,10 @@ readDaemonStatusFile file = parse <$> readFile file
 				status { lastRunning = Just v }
 			| key == "scanComplete" = parseval readish $ \v ->
 				status { scanComplete = v }
+			| key == "sanityCheckRunning" = parseval readish $ \v ->
+				status { sanityCheckRunning = v }
+			| key == "lastSanityCheck" = parseval readtime $ \v ->
+				status { lastSanityCheck = Just v }
 			| otherwise = status -- unparsable line
 			where
 				(key, value) = separate (== ':') line

Assistant/SanityChecker.hs

@@ -0,0 +1,56 @@
+{- git-annex assistant sanity checker
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -}
+
+module Assistant.SanityChecker (
+	sanityCheckerThread
+) where
+
+import Common.Annex
+import Assistant.DaemonStatus
+import Assistant.ThreadedMonad
+import Utility.ThreadScheduler
+
+import Data.Time.Clock.POSIX
+
+{- This thread wakes up occasionally to make sure the tree is in good shape. -}
+sanityCheckerThread :: ThreadState -> DaemonStatusHandle -> IO ()
+sanityCheckerThread st status = forever $ do
+	waitForNextCheck st status
+
+	runThreadState st $
+		modifyDaemonStatus status $ \s -> s
+				{ sanityCheckRunning = True }
+
+	now <- getPOSIXTime -- before check started
+	ok <- catchBoolIO $ runThreadState st check
+
+	runThreadState st $ do
+		modifyDaemonStatus status $ \s -> s
+			{ sanityCheckRunning = False
+			, lastSanityCheck =
+				if ok
+					then Just now
+					else lastSanityCheck s
+			}
+
+{- Only run one check per day, from the time of the last check. -}
+waitForNextCheck :: ThreadState -> DaemonStatusHandle -> IO ()
+waitForNextCheck st status = do
+	v <- runThreadState st $
+		lastSanityCheck <$> getDaemonStatus status
+	now <- getPOSIXTime
+	threadDelaySeconds $ Seconds $ calcdelay now v
+	where
+		calcdelay _ Nothing = oneDay
+		calcdelay now (Just lastcheck)
+			| lastcheck < now = oneDay - truncate (now - lastcheck)
+			| otherwise = oneDay
+
+check  :: Annex Bool
+check = do
+	return True
+
+oneDay :: Int
+oneDay = 24 * 60 * 60