![Joey Hess](/assets/img/avatar_default.png)
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.
89 lines
2.7 KiB
Haskell
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
|