git-annex/Assistant/Threads/SanityChecker.hs
Joey Hess 3cc1885793 move DaemonStatus manipulation out of the Annex monad to IO
I've convinced myself that nothing in DaemonStatus can deadlock,
as it always keepts the TMVar full. That was the only reason it was in the
Annex monad.
2012-07-28 18:02:11 -04:00

89 lines
2.7 KiB
Haskell

{- 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.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 status transferqueue changechan = forever $ do
waitForNextCheck status
debug thisThread ["starting sanity check"]
modifyDaemonStatus_ status $ \s -> s
{ sanityCheckRunning = True }
now <- getPOSIXTime -- before check started
catchIO (check st status transferqueue changechan)
(runThreadState st . warning . show)
modifyDaemonStatus_ status $ \s -> s
{ sanityCheckRunning = False
, lastSanityCheck = Just now
}
debug thisThread ["sanity check complete"]
{- Only run one check per day, from the time of the last check. -}
waitForNextCheck :: DaemonStatusHandle -> IO ()
waitForNextCheck status = do
v <- lastSanityCheck <$> getDaemonStatus status
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 ()
check st status transferqueue changechan = do
g <- runThreadState st $ do
showSideAction "Running daily check"
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
where
toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime)
slop = fromIntegral tenMinutes
insanity m = runThreadState st $ warning m
addsymlink file s = do
insanity $ "found unstaged symlink: " ++ file
Watcher.runHandler thisThread st status
transferqueue changechan
Watcher.onAddSymlink file s