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
|
{- git-annex assistant general preferences
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
module Assistant.WebApp.Configurators.Preferences (
getPreferencesR,
postPreferencesR
) where
import Assistant.WebApp.Common
import qualified Annex
import qualified Git
import Config
import Config.Files
import Config.NumCopies
import Utility.DataUnits
import Git.Config
import Types.Distribution
import qualified Build.SysConfig
import qualified Data.Text as T
data PrefsForm = PrefsForm
{ diskReserve :: Text
, numCopies :: Int
, autoStart :: Bool
, autoUpgrade :: AutoUpgrade
, debugEnabled :: Bool
}
prefsAForm :: PrefsForm -> MkAForm PrefsForm
prefsAForm def = PrefsForm
<$> areq (storageField `withNote` diskreservenote)
(bfs "Disk reserve") (Just $ diskReserve def)
<*> areq (positiveIntField `withNote` numcopiesnote)
(bfs "Number of copies") (Just $ numCopies def)
<*> areq (checkBoxField `withNote` autostartnote)
"Auto start" (Just $ autoStart def)
<*> areq (selectFieldList autoUpgradeChoices)
(bfs autoUpgradeLabel) (Just $ autoUpgrade def)
<*> areq (checkBoxField `withNote` debugnote)
"Enable debug logging" (Just $ debugEnabled def)
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 Build.SysConfig.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 <- fromRepo Git.repoPath
liftIO $ if autoStart p
then addAutoStartFile here
else removeAutoStartFile here
setConfig (annexConfig "debug") (boolConfig $ debugEnabled p)
liftIO $ if debugEnabled p
then enableDebugOutput
else disableDebugOutput
getPreferencesR :: Handler Html
getPreferencesR = postPreferencesR
postPreferencesR :: Handler Html
postPreferencesR = page "Preferences" (Just Configuration) $ do
((result, form), enctype) <- liftH $ do
current <- liftAnnex getPrefs
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 <- fromRepo Git.repoPath
any (`equalFilePath` here) <$> liftIO readAutoStartFile
|
