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

Assistant/Threads/WebApp.hs

@@ -24,6 +24,7 @@ import Assistant.WebApp.Configurators.Pairing
 import Assistant.WebApp.Configurators.AWS
 import Assistant.WebApp.Configurators.WebDAV
 import Assistant.WebApp.Configurators.XMPP
+import Assistant.WebApp.Configurators.Preferences
 import Assistant.WebApp.Documentation
 import Assistant.WebApp.Control
 import Assistant.WebApp.OtherRepos

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

Assistant/WebApp/Form.hs

@@ -45,19 +45,6 @@ withNote field note = field { fieldView = newview }
 		let fieldwidget = (fieldView field) theId name attrs val isReq
 		in [whamlet|^{fieldwidget}&nbsp;&nbsp;<span>^{note}</span>|]
 
-
-{- Makes a help button be displayed after a field, that displays a help
- - widget when clicked. Requires a unique ident for the help. -}
-withHelp :: Field sub master v -> GWidget sub master () -> Text -> Field sub master v
-withHelp field help ident = withNote field note
-  where
-	note = [whamlet|
-<a .btn data-toggle="collapse" data-target="##{ident}">
-  Help
-<div ##{ident} .collapse>
-  ^{help}
-|]
-
 data EnableEncryption = SharedEncryption | NoEncryption
 	deriving (Eq)
 

Assistant/WebApp/OtherRepos.hs

@@ -29,11 +29,10 @@ getRepositorySwitcherR = page "Switch repository" Nothing $ do
 
 listOtherRepos :: IO [(String, String)]
 listOtherRepos = do
-	f <- autoStartFile
+	dirs <- readAutoStartFile
 	pwd <- getCurrentDirectory
-	dirs <- filter (\d -> not $ d `dirContains` pwd) . nub
+	gooddirs <- filterM doesDirectoryExist $
-		<$> ifM (doesFileExist f) ( lines <$> readFile f, return [])
+		filter (\d -> not $ d `dirContains` pwd) dirs
-	gooddirs <- filterM doesDirectoryExist dirs
 	names <- mapM relHome gooddirs
 	return $ sort $ zip names gooddirs
 

Assistant/WebApp/routes

@@ -13,6 +13,7 @@
 
 /config ConfigurationR GET
 /config/repository RepositoriesR GET
+/config/preferences PreferencesR GET
 /config/xmpp XMPPR GET
 /config/xmpp/for/pairing XMPPForPairingR GET
 

Command/Assistant.hs

@@ -50,21 +50,17 @@ checkAutoStart = ifM (elem "--autostart" <$> getArgs)
 
 autoStart :: IO ()
 autoStart = do
-	autostartfile <- autoStartFile
+	dirs <- liftIO readAutoStartFile
-	let nothing = error $ "Nothing listed in " ++ autostartfile
+	when (null dirs) $ do
-	ifM (doesFileExist autostartfile)
+		f <- autoStartFile
-		( do
+		error $ "Nothing listed in " ++ f
-			dirs <- nub . lines <$> readFile autostartfile
+	program <- readProgramFile
-			program <- readProgramFile
+	forM_ dirs $ \d -> do
-			when (null dirs) nothing
+		putStrLn $ "git-annex autostart in " ++ d
-			forM_ dirs $ \d -> do
+		ifM (catchBoolIO $ go program d)
-				putStrLn $ "git-annex autostart in " ++ d
+			( putStrLn "ok"
-				ifM (catchBoolIO $ go program d)
+			, putStrLn "failed"
-					( putStrLn "ok"
+			)
-					, putStrLn "failed"
-					)
-		, nothing
-		)
   where
 	go program dir = do
 		changeWorkingDirectory dir

Command/WebApp.hs

@@ -64,20 +64,13 @@ start' allowauto = do
 		liftIO $ isJust <$> checkDaemon pidfile
 	checkshim f = liftIO $ doesFileExist f
 
-{- When run without a repo, see if there is an autoStartFile,
+{- When run without a repo, start the first available listed repository in
- - and if so, start the first available listed repository.
+ - the autostart file. If not, it's our first time being run! -}
- - If not, it's our first time being run! -}
 startNoRepo :: IO ()
 startNoRepo = do
-	autostartfile <- autoStartFile
+	dirs <- liftIO $ filterM doesDirectoryExist =<< readAutoStartFile
-	ifM (doesFileExist autostartfile) ( autoStart autostartfile , firstRun )
+	case dirs of
-
+		[] -> firstRun
-autoStart :: FilePath -> IO ()
-autoStart autostartfile = do
-	dirs <- nub . lines <$> readFile autostartfile
-	edirs <- filterM doesDirectoryExist dirs
-	case edirs of
-		[] -> firstRun -- what else can I do? Nothing works..
 		(d:_) -> do
 			changeWorkingDirectory d
 			state <- Annex.new =<< Git.CurrentRepo.get

Locations/UserConfig.hs

@@ -8,6 +8,7 @@
 module Locations.UserConfig where
 
 import Common
+import Utility.TempFile
 import Utility.FreeDesktop
 
 {- ~/.config/git-annex/file -}
@@ -19,6 +20,31 @@ userConfigFile file = do
 autoStartFile :: IO FilePath
 autoStartFile = userConfigFile "autostart"
 
+{- Returns anything listed in the autostart file (which may not exist). -}
+readAutoStartFile :: IO [FilePath]
+readAutoStartFile = do
+	f <- autoStartFile
+	nub . lines <$> catchDefaultIO "" (readFile f)
+
+{- Adds a directory to the autostart file. -}
+addAutoStartFile :: FilePath -> IO ()
+addAutoStartFile path = do
+	dirs <- readAutoStartFile
+	when (path `notElem` dirs) $ do
+		f <- autoStartFile
+		createDirectoryIfMissing True (parentDir f)
+		viaTmp writeFile f $ unlines $ dirs ++ [path]
+
+{- Removes a directory from the autostart file. -}
+removeAutoStartFile :: FilePath -> IO ()
+removeAutoStartFile path = do
+	dirs <- readAutoStartFile
+	when (path `elem` dirs) $ do
+		f <- autoStartFile
+		createDirectoryIfMissing True (parentDir f)
+		viaTmp writeFile f $ unlines $
+			filter (not . equalFilePath path) dirs
+
 {- The path to git-annex is written here; which is useful when cabal
  - has installed it to some aweful non-PATH location. -}
 programFile :: IO FilePath

debian/changelog

@@ -13,6 +13,8 @@ git-annex (4.20130228) UNRELEASED; urgency=low
     automatic commits from causing git-gc runs.
   * assistant: If gc.auto=0, run git-gc once a day, packing loose objects
     very non-aggressively.
+  * webapp: New preferences page allows enabling/disabling debug logging
+    at runtime, as well as configuring numcopies and diskreserve.
 
  -- Joey Hess <joeyh@debian.org>  Wed, 27 Feb 2013 23:20:40 -0400
 

doc/design/assistant/webapp.mdwn

@@ -30,7 +30,7 @@ The webapp is a web server that displays a shiny interface.
 * Display something sane when kqueue runs out of file descriptors.
 * allow removing git remotes **done**
 * allow disabling syncing to here, which should temporarily disable all
-  local syncing.
+  local syncing. **done**
 
 ## first start **done**
 

templates/configurators/main.hamlet

@@ -4,9 +4,9 @@
       <h3>
         <a href="@{RepositoriesR}">
           Manage repositories
-     <p>
+      <p>
-       Distribute the files in this repository to other devices, #
+        Distribute the files in this repository to other devices, #
-       make backups, and more, by adding repositories.
+        make backups, and more, by adding repositories.
     <div .span4>
       $if xmppconfigured
         <h3>
@@ -21,4 +21,10 @@
             Configure jabber account
        <p>
          Keep in touch with remote devices, and with your friends, #
-         by configuring a jabber account.
+    <div .span4>
+      <h3>
+        <a href="@{PreferencesR}">
+          Preferences
+      <p>
+        Tune the behavior of git-annex, including how many copies #
+        to retain of each file, and how much disk space it can use.

templates/configurators/preferences.hamlet

@@ -0,0 +1,13 @@
+<div .span9 .hero-unit>
+  <h2>
+    Preferences
+  <p>
+    <form .form-horizontal enctype=#{enctype}>
+      <fieldset>
+        ^{form}
+        ^{webAppFormAuthToken}
+        <div .form-actions>
+          <button .btn .btn-primary type=submit>
+            Save Preferences
+          <a .btn href="@{ConfigurationR}">
+            Cancel