webapp: New preferences page allows enabling/disabling debug logging at runtime, as well as configuring numcopies and diskreserve.

Assistant/WebApp/Configurators/Local.hs

@@ -154,7 +154,7 @@ getNewRepositoryR = page "Add another repository" (Just Configuration) $ do
 			liftIO $ makeRepo path False
 			u <- liftIO $ initRepo True path Nothing
 			lift $ runAnnex () $ setStandardGroup u ClientGroup
-			liftIO $ addAutoStart path
+			liftIO $ addAutoStartFile path
 			liftIO $ startAssistant path
 			askcombine u path
 		_ -> $(widgetFile "configurators/newrepository")
@@ -274,7 +274,7 @@ startFullAssistant path = do
 		u <- initRepo True path Nothing
 		inDir path $ 
 			setStandardGroup u ClientGroup
-		addAutoStart path
+		addAutoStartFile path
 		changeWorkingDirectory path
 		fromJust $ postFirstRun webapp
 	redirect $ T.pack url
@@ -323,13 +323,6 @@ initRepo primary_assistant_repo dir desc = inDir dir $ do
 			[Param "config", Param "gc.auto", Param "0"]
 	getUUID
 
-{- Adds a directory to the autostart file. -}
-addAutoStart :: FilePath -> IO ()
-addAutoStart path = do
-	autostart <- autoStartFile
-	createDirectoryIfMissing True (parentDir autostart)
-	appendFile autostart $ path ++ "\n"
-
 {- Checks if the user can write to a directory.
  -
  - The directory may be in the process of being created; if so

Assistant/WebApp/Configurators/Preferences.hs

@@ -0,0 +1,99 @@
+{- git-annex assistant general preferences
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+
+module Assistant.WebApp.Configurators.Preferences (
+	getPreferencesR
+) where
+
+import Assistant.WebApp.Common
+import qualified Annex
+import qualified Git
+import Config
+import Locations.UserConfig
+import Utility.DataUnits
+
+import qualified Data.Text as T
+import System.Log.Logger
+
+data PrefsForm = PrefsForm
+	{ diskReserve :: Text
+	, numCopies :: Int
+	, autoStart :: Bool
+	, debugEnabled :: Bool
+	}
+
+prefsAForm :: PrefsForm -> AForm WebApp WebApp PrefsForm
+prefsAForm def = PrefsForm
+	<$> areq (storageField `withNote` diskreservenote)
+		"Disk reserve" (Just $ diskReserve def)
+	<*> areq (positiveIntField `withNote` numcopiesnote)
+		"Number of copies" (Just $ numCopies def)
+	<*> areq (checkBoxField `withNote` autostartnote)
+		"Auto start" (Just $ autoStart 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.|]
+
+	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)
+	<*> (annexNumCopies <$> Annex.getGitConfig)
+	<*> inAutoStartFile
+	<*> ((==) <$> (pure $ Just DEBUG) <*> (liftIO $ getLevel <$> getRootLogger))
+  where
+
+storePrefs :: PrefsForm -> Annex ()
+storePrefs p = do
+	setConfig (annexConfig "diskreserve") (T.unpack $ diskReserve p)
+	setConfig (annexConfig "numcopies") (show $ numCopies p)
+	unlessM ((==) <$> pure (autoStart p) <*> inAutoStartFile) $ do
+		here <- fromRepo Git.repoPath
+		liftIO $ if autoStart p
+			then addAutoStartFile here
+			else removeAutoStartFile here
+	liftIO $ updateGlobalLogger rootLoggerName $ setLevel $
+		if debugEnabled p then DEBUG else WARNING
+
+getPreferencesR :: Handler RepHtml
+getPreferencesR = page "Preferences" (Just Configuration) $ do
+	((result, form), enctype) <- lift $ do
+		current <- runAnnex undefined getPrefs
+		runFormGet $ renderBootstrap $ prefsAForm current
+	case result of
+		FormSuccess new -> lift $ do
+			runAnnex undefined $ storePrefs new
+			redirect ConfigurationR
+		_ -> $(widgetFile "configurators/preferences")
+
+inAutoStartFile :: Annex Bool
+inAutoStartFile = do
+	here <- fromRepo Git.repoPath
+	any (`equalFilePath` here) <$> liftIO readAutoStartFile