UI for configuring fscks of remotes
This commit is contained in:
Joey Hess
parent
1ffb3bb0ba
commit
42c4a86d16
4 changed files with 69 additions and 43 deletions
|
|
@ -13,7 +13,6 @@ 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 qualified Text.Hamlet as Hamlet
|
||||
|
||||
import Assistant.WebApp.Common
|
||||
import Types.ScheduledActivity
|
||||
|
|
@ -21,17 +20,19 @@ import Utility.HumanTime
|
|||
import Utility.Scheduled
|
||||
import Logs.Schedule
|
||||
import Annex.UUID
|
||||
import qualified Remote
|
||||
import Assistant.DaemonStatus
|
||||
|
||||
{- 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. -}
|
||||
fsckForm :: Bool -> ScheduledActivity -> Widget
|
||||
fsckForm new activity = do
|
||||
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 $ runFormPost $ fsckForm' new activity
|
||||
((res, form), enctype) <- liftH $ runFsckForm new activity
|
||||
case res of
|
||||
FormSuccess _ -> noop
|
||||
_ -> $(widgetFile "configurators/fsck/form")
|
||||
|
|
@ -40,49 +41,73 @@ fsckForm new activity = do
|
|||
- some Annex action on it. -}
|
||||
withFsckForm :: (ScheduledActivity -> Annex ()) -> Handler ()
|
||||
withFsckForm a = do
|
||||
((res, _form), _enctype) <- runFormPost $ fsckForm' False defaultFsck
|
||||
((res, _form), _enctype) <- runFsckForm False defaultFsck
|
||||
case res of
|
||||
FormSuccess activity -> liftAnnex $ a activity
|
||||
_ -> noop
|
||||
|
||||
fsckForm' :: Bool -> ScheduledActivity -> Hamlet.Html -> MkMForm ScheduledActivity
|
||||
fsckForm' new activity@(ScheduledSelfFsck (Schedule r t) d) msg = do
|
||||
(durationRes, durationView) <- mreq intField "" (Just $ durationSeconds d `quot` 60 )
|
||||
(timeRes, timeView) <- mreq (selectFieldList times) "" (Just t)
|
||||
(recurranceRes, recurranceView) <- mreq (selectFieldList recurrances) "" (Just r)
|
||||
let form = do
|
||||
webAppFormAuthToken
|
||||
u <- liftAnnex getUUID
|
||||
$(widgetFile "configurators/fsck/formcontent")
|
||||
let formresult = ScheduledSelfFsck
|
||||
<$> (Schedule <$> recurranceRes <*> timeRes)
|
||||
<*> (Duration <$> ((60 *) <$> durationRes))
|
||||
return (formresult, form)
|
||||
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
|
||||
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 1)
|
||||
, ("every Monday", Weekly 2)
|
||||
, ("every Tuesday", Weekly 3)
|
||||
, ("every Wednesday", Weekly 4)
|
||||
, ("every Thursday", Weekly 5)
|
||||
, ("every Friday", Weekly 6)
|
||||
, ("every Saturday", Weekly 7)
|
||||
, ("on the 1st of the month", Monthly 1)
|
||||
, ("mid-month", Monthly 15)
|
||||
, ("once a year", Yearly 1)
|
||||
, ("twice a year", (Divisible 6 $ Monthly 1))
|
||||
, ("quarterly", (Divisible 4 $ Monthly 1))
|
||||
]
|
||||
go (Schedule r t) d ru = do
|
||||
u <- liftAnnex getUUID
|
||||
repolist <- liftAssistant (getrepolist ru)
|
||||
runFormPost $ \msg -> do
|
||||
(reposRes, reposView) <- mreq (selectFieldList repolist) "" (Just ru)
|
||||
(durationRes, durationView) <- mreq intField "" (Just $ durationSeconds d `quot` 60 )
|
||||
(timeRes, timeView) <- mreq (selectFieldList times) "" (Just t)
|
||||
(recurranceRes, recurranceView) <- mreq (selectFieldList recurrances) "" (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 1)
|
||||
, ("every Monday", Weekly 2)
|
||||
, ("every Tuesday", Weekly 3)
|
||||
, ("every Wednesday", Weekly 4)
|
||||
, ("every Thursday", Weekly 5)
|
||||
, ("every Friday", Weekly 6)
|
||||
, ("every Saturday", Weekly 7)
|
||||
, ("monthly", Monthly 1)
|
||||
, ("twice a month", Divisible 2 (Weekly 1))
|
||||
, ("yearly", Yearly 1)
|
||||
, ("twice a year", Divisible 6 (Monthly 1))
|
||||
, ("quarterly", Divisible 4 (Monthly 1))
|
||||
]
|
||||
ensurevalue v desc l = case M.lookup v (M.fromList $ map (\(x,y) -> (y,x)) l) of
|
||||
Just _ -> l
|
||||
Nothing -> (desc, v) : l
|
||||
fsckForm' new (ScheduledRemoteFsck u s d) _msg = error "TODO"
|
||||
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 :: ScheduledActivity
|
||||
defaultFsck = ScheduledSelfFsck (Schedule Daily AnyTime) (Duration $ 60*60)
|
||||
|
|
|
|||
|
|
@ -1,2 +1,4 @@
|
|||
input[type=number]
|
||||
width: 5em
|
||||
select
|
||||
width: 10em
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@
|
|||
<p>
|
||||
Currently scheduled checks:
|
||||
$forall check <- checks
|
||||
^{fsckForm False check}
|
||||
^{showFsckForm False check}
|
||||
<p>
|
||||
Add a check:
|
||||
^{fsckForm True defaultFsck}
|
||||
^{showFsckForm True defaultFsck}
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
#{msg}
|
||||
<p>
|
||||
<div .input-prepend .input-append>
|
||||
Check this repository for #
|
||||
Check ^{fvInput reposView} for #
|
||||
^{fvInput durationView} minutes #
|
||||
^{fvInput recurranceView} #
|
||||
starting at ^{fvInput timeView} #
|
||||
|
|
@ -13,4 +13,3 @@
|
|||
Save
|
||||
<a .btn href="@{RemoveActivityR u activity}">
|
||||
Remove
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue