git-annex/Assistant/WebApp/Configurators/Fsck.hs

{- git-annex assistant fsck configuration
 -
 - Copyright 2013 Joey Hess <id@joeyh.name>
 -
 - 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)
			(recurrenceRes, recurrenceView) <- mreq (selectFieldList recurrences) (bfs "") (Just r)
			let form = do
				webAppFormAuthToken
				$(widgetFile "configurators/fsck/formcontent")
			let formresult = mkFsck
				<$> pure u
				<*> reposRes
				<*> (Schedule <$> recurrenceRes <*> 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]
		recurrences :: [(Text, Recurrence)]
		recurrences = ensurevalue r (T.pack $ fromRecurrence 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 =<< Annex.Branch.commitMessage
	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 d = FsckPreferences
	<$> areq (checkBoxField `withNote` nudgenote) "Reminders" (Just $ enableFsckNudge d)
  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