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
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
|
{- git-annex assistant fsck configuration
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
module Assistant.WebApp.Configurators.Fsck where
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
import Assistant.WebApp.Common
import Types.ScheduledActivity
import Utility.HumanTime
import Utility.Scheduled
import Logs.Schedule
import Annex.UUID
import qualified Remote
import Assistant.DaemonStatus
import qualified Annex.Branch
import Assistant.Fsck
import Config
import Git.Config
import qualified Annex
{- This adds a form to the page. It does not handle posting of the form,
- because unlike a typical yesod form that posts using the same url
- that generated it, this form posts using one of two other routes. -}
showFsckForm :: Bool -> ScheduledActivity -> Widget
showFsckForm new activity = do
u <- liftAnnex getUUID
let action = if new
then AddActivityR u
else ChangeActivityR u activity
((res, form), enctype) <- liftH $ runFsckForm new activity
case res of
FormSuccess _ -> noop
_ -> $(widgetFile "configurators/fsck/form")
{- This does not display a form, but it does get it from a post, and run
- some Annex action on it. -}
withFsckForm :: (ScheduledActivity -> Annex ()) -> Handler ()
withFsckForm a = do
((res, _form), _enctype) <- runFsckForm False $ defaultFsck Nothing
case res of
FormSuccess activity -> liftAnnex $ a activity
_ -> noop
mkFsck :: UUID -> UUID -> Schedule -> Duration -> ScheduledActivity
mkFsck hereu u s d
| u == hereu = ScheduledSelfFsck s d
| otherwise = ScheduledRemoteFsck u s d
runFsckForm :: Bool -> ScheduledActivity -> Handler ((FormResult ScheduledActivity, Widget), Enctype)
runFsckForm new activity = case activity of
ScheduledSelfFsck s d -> go s d =<< liftAnnex getUUID
ScheduledRemoteFsck ru s d -> go s d ru
where
go (Schedule r t) d ru = do
u <- liftAnnex getUUID
repolist <- liftAssistant (getrepolist ru)
runFormPostNoToken $ \msg -> do
(reposRes, reposView) <- mreq (selectFieldList repolist) (bfs "") (Just ru)
(durationRes, durationView) <- mreq intField (bfs "") (Just $ durationSeconds d `quot` 60 )
(timeRes, timeView) <- mreq (selectFieldList times) (bfs "") (Just t)
(recurranceRes, recurranceView) <- mreq (selectFieldList recurrances) (bfs "") (Just r)
let form = do
webAppFormAuthToken
$(widgetFile "configurators/fsck/formcontent")
let formresult = mkFsck
<$> pure u
<*> reposRes
<*> (Schedule <$> recurranceRes <*> timeRes)
<*> (Duration <$> ((60 *) <$> durationRes))
return (formresult, form)
where
times :: [(Text, ScheduledTime)]
times = ensurevalue t (T.pack $ fromScheduledTime t) $
map (\x -> (T.pack $ fromScheduledTime x, x)) $
AnyTime : map (\h -> SpecificTime h 0) [0..23]
recurrances :: [(Text, Recurrance)]
recurrances = ensurevalue r (T.pack $ fromRecurrance r) $
[ ("every day", Daily)
, ("every Sunday", Weekly $ Just 1)
, ("every Monday", Weekly $ Just 2)
, ("every Tuesday", Weekly $ Just 3)
, ("every Wednesday", Weekly $ Just 4)
, ("every Thursday", Weekly $ Just 5)
, ("every Friday", Weekly $ Just 6)
, ("every Saturday", Weekly $ Just 7)
, ("monthly", Monthly Nothing)
, ("twice a month", Divisible 2 (Weekly Nothing))
, ("yearly", Yearly Nothing)
, ("twice a year", Divisible 6 (Monthly Nothing))
, ("quarterly", Divisible 4 (Monthly Nothing))
]
ensurevalue v desc l = case M.lookup v (M.fromList $ map (\(x,y) -> (y,x)) l) of
Just _ -> l
Nothing -> (desc, v) : l
getrepolist :: UUID -> Assistant [(Text, UUID)]
getrepolist ensureu = do
-- It is possible to have fsck jobs for remotes that
-- do not implement remoteFsck, but it's not too useful,
-- so omit them from the UI normally.
remotes <- filter (\r -> Remote.uuid r == ensureu || isJust (Remote.remoteFsck r)) . syncRemotes
<$> getDaemonStatus
u <- liftAnnex getUUID
let us = u : (map Remote.uuid remotes)
liftAnnex $
zip <$> (map T.pack <$> Remote.prettyListUUIDs us) <*> pure us
defaultFsck :: Maybe Remote -> ScheduledActivity
defaultFsck Nothing = ScheduledSelfFsck (Schedule Daily AnyTime) (Duration $ 60*60)
defaultFsck (Just r) = ScheduledRemoteFsck (Remote.uuid r) (Schedule Daily AnyTime) (Duration $ 60*60)
showFsckStatus :: ScheduledActivity -> Widget
showFsckStatus activity = do
m <- liftAnnex getLastRunTimes
let lastrun = M.lookup activity m
$(widgetFile "configurators/fsck/status")
getConfigFsckR :: Handler Html
getConfigFsckR = postConfigFsckR
postConfigFsckR :: Handler Html
postConfigFsckR = page "Consistency checks" (Just Configuration) $ do
scheduledchecks <- liftAnnex $
S.toList <$> (scheduleGet =<< getUUID)
rs <- liftAssistant $
filter fsckableRemote . syncRemotes <$> getDaemonStatus
recommendedchecks <- liftAnnex $ map defaultFsck
<$> filterM (not <$$> checkFscked) (Nothing : map Just rs)
$(widgetFile "configurators/fsck")
changeSchedule :: Handler () -> Handler Html
changeSchedule a = do
a
liftAnnex $ Annex.Branch.commit "update"
redirect ConfigFsckR
getRemoveActivityR :: UUID -> ScheduledActivity -> Handler Html
getRemoveActivityR u activity = changeSchedule $
liftAnnex $ scheduleRemove u activity
getAddActivityR :: UUID -> Handler Html
getAddActivityR = postAddActivityR
postAddActivityR :: UUID -> Handler Html
postAddActivityR u = changeSchedule $
withFsckForm $ scheduleAdd u
getChangeActivityR :: UUID -> ScheduledActivity -> Handler Html
getChangeActivityR = postChangeActivityR
postChangeActivityR :: UUID -> ScheduledActivity -> Handler Html
postChangeActivityR u oldactivity = changeSchedule $
withFsckForm $ \newactivity -> scheduleChange u $
S.insert newactivity . S.delete oldactivity
data FsckPreferences = FsckPreferences
{ enableFsckNudge :: Bool
}
getFsckPreferences :: Annex FsckPreferences
getFsckPreferences = FsckPreferences
<$> (annexFsckNudge <$> Annex.getGitConfig)
fsckPreferencesAForm :: FsckPreferences -> MkAForm FsckPreferences
fsckPreferencesAForm def = FsckPreferences
<$> areq (checkBoxField `withNote` nudgenote) "Reminders" (Just $ enableFsckNudge def)
where
nudgenote = [whamlet|Remind me when using repositories that lack consistency checks.|]
runFsckPreferencesForm :: Handler ((FormResult FsckPreferences, Widget), Enctype)
runFsckPreferencesForm = do
prefs <- liftAnnex getFsckPreferences
runFormPostNoToken $ renderBootstrap3 formLayout $ fsckPreferencesAForm prefs
where formLayout = BootstrapHorizontalForm (ColSm 0) (ColSm 2) (ColSm 0) (ColSm 10)
showFsckPreferencesForm :: Widget
showFsckPreferencesForm = do
((res, form), enctype) <- liftH $ runFsckPreferencesForm
case res of
FormSuccess _ -> noop
_ -> $(widgetFile "configurators/fsck/preferencesform")
postConfigFsckPreferencesR :: Handler Html
postConfigFsckPreferencesR = do
((res, _form), _enctype) <- runFsckPreferencesForm
case res of
FormSuccess prefs ->
liftAnnex $ setConfig (annexConfig "fscknudge")
(boolConfig $ enableFsckNudge prefs)
_ -> noop
redirect ConfigFsckR
|
