93 lines
2.8 KiB
Haskell
93 lines
2.8 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 st status
|
|
|
|
debug thisThread ["starting sanity check"]
|
|
|
|
runThreadState st $
|
|
modifyDaemonStatus_ status $ \s -> s
|
|
{ sanityCheckRunning = True }
|
|
|
|
now <- getPOSIXTime -- before check started
|
|
catchIO (check st status transferqueue changechan)
|
|
(runThreadState st . warning . show)
|
|
|
|
runThreadState st $ do
|
|
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 :: 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 = 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
|