blob: 80644105850fd3a52a5842e3a6d6f2b81f7d3f45 (
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
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
|
{- 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 (
sanityCheckerDailyThread,
sanityCheckerHourlyThread
) where
import Assistant.Common
import Assistant.DaemonStatus
import Assistant.Alert
import qualified Git.LsFiles
import qualified Git.Command
import Utility.ThreadScheduler
import qualified Assistant.Threads.Watcher as Watcher
import Utility.LogFile
import Data.Time.Clock.POSIX
{- This thread wakes up hourly for inxepensive frequent sanity checks. -}
sanityCheckerHourlyThread :: NamedThread
sanityCheckerHourlyThread = namedThread "SanityCheckerHourly" $ forever $ do
liftIO $ threadDelaySeconds $ Seconds oneHour
hourlyCheck
{- This thread wakes up daily to make sure the tree is in good shape. -}
sanityCheckerDailyThread :: NamedThread
sanityCheckerDailyThread = namedThread "SanityCheckerDaily" $ forever $ do
waitForNextCheck
debug ["starting sanity check"]
void $ alertWhile sanityCheckAlert go
debug ["sanity check complete"]
where
go = do
modifyDaemonStatus_ $ \s -> s { sanityCheckRunning = True }
now <- liftIO $ getPOSIXTime -- before check started
r <- either showerr return =<< tryIO <~> dailyCheck
modifyDaemonStatus_ $ \s -> s
{ sanityCheckRunning = False
, lastSanityCheck = Just now
}
return r
showerr e = do
liftAnnex $ warning $ show e
return False
{- Only run one check per day, from the time of the last check. -}
waitForNextCheck :: Assistant ()
waitForNextCheck = do
v <- lastSanityCheck <$> getDaemonStatus
now <- liftIO getPOSIXTime
liftIO $ threadDelaySeconds $ Seconds $ calcdelay now v
where
calcdelay _ Nothing = oneDay
calcdelay now (Just lastcheck)
| lastcheck < now = max oneDay $
oneDay - truncate (now - lastcheck)
| otherwise = oneDay
{- 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. -}
dailyCheck :: Assistant Bool
dailyCheck = do
g <- liftAnnex gitRepo
-- Find old unstaged symlinks, and add them to git.
(unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo False ["."] g
now <- liftIO $ getPOSIXTime
forM_ unstaged $ \file -> do
ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file
case ms of
Just s | toonew (statusChangeTime s) now -> noop
| isSymbolicLink s -> addsymlink file ms
_ -> noop
liftIO $ void cleanup
{- Allow git-gc to run once per day. More frequent gc is avoided
- to avoid slowing things down. -}
void $ liftIO $ Git.Command.runBool [Param "gc", Param "--auto"] g
return True
where
toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime)
slop = fromIntegral tenMinutes
insanity msg = do
liftAnnex $ warning msg
void $ addAlert $ sanityCheckFixAlert msg
addsymlink file s = do
Watcher.runHandler Watcher.onAddSymlink file s
insanity $ "found unstaged symlink: " ++ file
hourlyCheck :: Assistant ()
hourlyCheck = checkLogSize 0
{- Rotate logs until log file size is < 1 mb. -}
checkLogSize :: Int -> Assistant ()
checkLogSize n = do
f <- liftAnnex $ fromRepo gitAnnexLogFile
logs <- liftIO $ listLogs f
totalsize <- liftIO $ sum <$> mapM filesize logs
when (totalsize > oneMegabyte) $ do
notice ["Rotated logs due to size:", show totalsize]
liftIO $ openLog f >>= redirLog
when (n < maxLogs + 1) $
checkLogSize $ n + 1
where
filesize f = fromIntegral . fileSize <$> liftIO (getFileStatus f)
oneMegabyte :: Int
oneMegabyte = 1000000
oneHour :: Int
oneHour = 60 * 60
oneDay :: Int
oneDay = 24 * oneHour
|
