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

125 lines
4 KiB
Haskell
Raw Normal View History

{- git-annex assistant general preferences
-
- Copyright 2013 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
2013-03-04 03:27:17 +00:00
{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
module Assistant.WebApp.Configurators.Preferences (
2013-03-16 22:48:23 +00:00
getPreferencesR,
postPreferencesR
) where
import Assistant.WebApp.Common
import qualified Annex
import qualified Git
import Config
import Config.Files.AutoStart
2015-04-30 18:02:56 +00:00
import Annex.NumCopies
import Utility.DataUnits
import Git.Config
import Types.Distribution
import qualified BuildInfo
import qualified Data.Text as T
import qualified System.FilePath.ByteString as P
data PrefsForm = PrefsForm
{ diskReserve :: Text
, numCopies :: Int
, autoStart :: Bool
, autoUpgrade :: AutoUpgrade
, enableDebug :: Bool
}
2013-06-03 20:33:05 +00:00
prefsAForm :: PrefsForm -> MkAForm PrefsForm
2015-01-28 20:11:28 +00:00
prefsAForm d = PrefsForm
<$> areq (storageField `withNote` diskreservenote)
2015-01-28 20:11:28 +00:00
(bfs "Disk reserve") (Just $ diskReserve d)
<*> areq (positiveIntField `withNote` numcopiesnote)
2015-01-28 20:11:28 +00:00
(bfs "Number of copies") (Just $ numCopies d)
<*> areq (checkBoxField `withNote` autostartnote)
2015-01-28 20:11:28 +00:00
"Auto start" (Just $ autoStart d)
<*> areq (selectFieldList autoUpgradeChoices)
2015-01-28 20:11:28 +00:00
(bfs autoUpgradeLabel) (Just $ autoUpgrade d)
<*> areq (checkBoxField `withNote` debugnote)
"Enable debug logging" (Just $ enableDebug d)
where
diskreservenote = [whamlet|<br>Avoid downloading files from other repositories when there is too little free disk space.|]
numcopiesnote = [whamlet|<br>Only drop a file after verifying that other repositories contain this many copies.|]
debugnote = [whamlet|<a href="@{LogR}">View Log</a>|]
autostartnote = [whamlet|Start the git-annex assistant at boot or on login.|]
autoUpgradeChoices :: [(Text, AutoUpgrade)]
autoUpgradeChoices =
[ ("ask me", AskUpgrade)
, ("enabled", AutoUpgrade)
, ("disabled", NoAutoUpgrade)
]
autoUpgradeLabel
| isJust BuildInfo.upgradelocation = "Auto upgrade"
| otherwise = "Auto restart on upgrade"
positiveIntField = check isPositive intField
where
isPositive i
| i > 0 = Right i
| otherwise = Left notPositive
notPositive :: Text
notPositive = "This should be 1 or more!"
storageField = check validStorage textField
where
validStorage t
| T.null t = Right t
| otherwise = case readSize dataUnits $ T.unpack t of
Nothing -> Left badParse
Just _ -> Right t
badParse :: Text
badParse = "Parse error. Expected something like \"100 megabytes\" or \"2 gb\""
getPrefs :: Annex PrefsForm
getPrefs = PrefsForm
<$> (T.pack . roughSize storageUnits False . annexDiskReserve <$> Annex.getGitConfig)
<*> (fromNumCopies <$> getNumCopies)
<*> inAutoStartFile
<*> (annexAutoUpgrade <$> Annex.getGitConfig)
<*> (annexDebug <$> Annex.getGitConfig)
storePrefs :: PrefsForm -> Annex ()
storePrefs p = do
setConfig (annexConfig "diskreserve") (T.unpack $ diskReserve p)
setGlobalNumCopies (NumCopies $ numCopies p)
unsetConfig (annexConfig "numcopies") -- deprecated
setConfig (annexConfig "autoupgrade") (fromAutoUpgrade $ autoUpgrade p)
unlessM ((==) <$> pure (autoStart p) <*> inAutoStartFile) $ do
here <- fromRawFilePath <$> fromRepo Git.repoPath
liftIO $ if autoStart p
then addAutoStartFile here
else removeAutoStartFile here
setConfig (annexConfig "debug") (boolConfig $ enableDebug p)
liftIO $ if enableDebug p
then enableDebugOutput
else disableDebugOutput
getPreferencesR :: Handler Html
2013-03-16 22:48:23 +00:00
getPreferencesR = postPreferencesR
postPreferencesR :: Handler Html
2013-03-16 22:48:23 +00:00
postPreferencesR = page "Preferences" (Just Configuration) $ do
((result, form), enctype) <- liftH $ do
current <- liftAnnex getPrefs
2014-04-18 00:07:09 +00:00
runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ prefsAForm current
case result of
FormSuccess new -> liftH $ do
liftAnnex $ storePrefs new
redirect ConfigurationR
_ -> $(widgetFile "configurators/preferences")
inAutoStartFile :: Annex Bool
inAutoStartFile = do
here <- liftIO . absPath =<< fromRepo Git.repoPath
any (`P.equalFilePath` here) . map toRawFilePath
<$> liftIO readAutoStartFile