blob: 69610c2a7b878438e130f6e51efd10a9b4b5f726 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
{- 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"]
alertWhile dstatus alert go
debug thisThread ["sanity check complete"]
where
go = do
modifyDaemonStatus_ dstatus $ \s -> s
{ sanityCheckRunning = True }
now <- getPOSIXTime -- before check started
catchIO (check st dstatus transferqueue changechan)
(runThreadState st . warning . show)
modifyDaemonStatus_ dstatus $ \s -> s
{ sanityCheckRunning = False
, lastSanityCheck = Just now
}
alert = activityAlert (Just "Running daily sanity check")
"to make sure I've not missed anything."
{- 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 ()
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
where
toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime)
slop = fromIntegral tenMinutes
insanity msg = do
runThreadState st $ warning msg
void $ addAlert dstatus $ Alert
{ alertClass = Warning
, alertHeader = Just "Fixed a problem"
, alertMessage = StringAlert $ unwords
[ "The daily sanity check found and fixed a problem:"
, msg
, "If these problems persist, consider filing a bug report."
]
, alertBlockDisplay = True
}
addsymlink file s = do
insanity $ "found unstaged symlink: " ++ file
Watcher.runHandler thisThread st dstatus
transferqueue changechan
Watcher.onAddSymlink file s
|
