From 08bdea7e52a28074722da472261c4e66c3392f59 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 3 Mar 2013 17:07:27 -0400 Subject: [PATCH] webapp: New preferences page allows enabling/disabling debug logging at runtime, as well as configuring numcopies and diskreserve. --- Assistant/Threads/WebApp.hs | 1 + Assistant/WebApp/Configurators/Local.hs | 11 +-- Assistant/WebApp/Configurators/Preferences.hs | 99 +++++++++++++++++++ Assistant/WebApp/Form.hs | 13 --- Assistant/WebApp/OtherRepos.hs | 7 +- Assistant/WebApp/routes | 1 + Command/Assistant.hs | 26 +++-- Command/WebApp.hs | 17 +--- Locations/UserConfig.hs | 26 +++++ debian/changelog | 2 + doc/design/assistant/webapp.mdwn | 2 +- templates/configurators/main.hamlet | 14 ++- templates/configurators/preferences.hamlet | 13 +++ 13 files changed, 174 insertions(+), 58 deletions(-) create mode 100644 Assistant/WebApp/Configurators/Preferences.hs create mode 100644 templates/configurators/preferences.hamlet diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index e2eed4588c..39b9c95c32 100644 --- a/Assistant/Threads/WebApp.hs +++ b/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 diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs index 53bd95d012..fd427467ec 100644 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/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 diff --git a/Assistant/WebApp/Configurators/Preferences.hs b/Assistant/WebApp/Configurators/Preferences.hs new file mode 100644 index 0000000000..923f2ef299 --- /dev/null +++ b/Assistant/WebApp/Configurators/Preferences.hs @@ -0,0 +1,99 @@ +{- git-annex assistant general preferences + - + - Copyright 2012 Joey Hess + - + - 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|
Avoid downloading files from other repositories when there is too little free disk space.|] + numcopiesnote = [whamlet|
Only drop a file after verifying that other repositories contain this many copies.|] + debugnote = [whamlet|View Log|] + 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 diff --git a/Assistant/WebApp/Form.hs b/Assistant/WebApp/Form.hs index 6605387170..20d2952850 100644 --- a/Assistant/WebApp/Form.hs +++ b/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}  ^{note}|] - -{- 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| - - Help -
- ^{help} -|] - data EnableEncryption = SharedEncryption | NoEncryption deriving (Eq) diff --git a/Assistant/WebApp/OtherRepos.hs b/Assistant/WebApp/OtherRepos.hs index b89022c5c8..b408dd8a5b 100644 --- a/Assistant/WebApp/OtherRepos.hs +++ b/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 - <$> ifM (doesFileExist f) ( lines <$> readFile f, return []) - gooddirs <- filterM doesDirectoryExist dirs + gooddirs <- filterM doesDirectoryExist $ + filter (\d -> not $ d `dirContains` pwd) dirs names <- mapM relHome gooddirs return $ sort $ zip names gooddirs diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes index 486278125f..6a393f5dea 100644 --- a/Assistant/WebApp/routes +++ b/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 diff --git a/Command/Assistant.hs b/Command/Assistant.hs index ea8a87a3d8..69a127b505 100644 --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -50,21 +50,17 @@ checkAutoStart = ifM (elem "--autostart" <$> getArgs) autoStart :: IO () autoStart = do - autostartfile <- autoStartFile - let nothing = error $ "Nothing listed in " ++ autostartfile - ifM (doesFileExist autostartfile) - ( do - dirs <- nub . lines <$> readFile autostartfile - program <- readProgramFile - when (null dirs) nothing - forM_ dirs $ \d -> do - putStrLn $ "git-annex autostart in " ++ d - ifM (catchBoolIO $ go program d) - ( putStrLn "ok" - , putStrLn "failed" - ) - , nothing - ) + dirs <- liftIO readAutoStartFile + when (null dirs) $ do + f <- autoStartFile + error $ "Nothing listed in " ++ f + program <- readProgramFile + forM_ dirs $ \d -> do + putStrLn $ "git-annex autostart in " ++ d + ifM (catchBoolIO $ go program d) + ( putStrLn "ok" + , putStrLn "failed" + ) where go program dir = do changeWorkingDirectory dir diff --git a/Command/WebApp.hs b/Command/WebApp.hs index 274a00c936..5e461ed218 100644 --- a/Command/WebApp.hs +++ b/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, - - and if so, start the first available listed repository. - - If not, it's our first time being run! -} +{- When run without a repo, start the first available listed repository in + - the autostart file. If not, it's our first time being run! -} startNoRepo :: IO () startNoRepo = do - autostartfile <- autoStartFile - ifM (doesFileExist autostartfile) ( autoStart autostartfile , 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.. + dirs <- liftIO $ filterM doesDirectoryExist =<< readAutoStartFile + case dirs of + [] -> firstRun (d:_) -> do changeWorkingDirectory d state <- Annex.new =<< Git.CurrentRepo.get diff --git a/Locations/UserConfig.hs b/Locations/UserConfig.hs index 3a6a27e911..429ed8fd55 100644 --- a/Locations/UserConfig.hs +++ b/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 diff --git a/debian/changelog b/debian/changelog index dab3e7b5ba..a241d4bfc1 100644 --- a/debian/changelog +++ b/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 Wed, 27 Feb 2013 23:20:40 -0400 diff --git a/doc/design/assistant/webapp.mdwn b/doc/design/assistant/webapp.mdwn index f714903733..b55d1b860e 100644 --- a/doc/design/assistant/webapp.mdwn +++ b/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** diff --git a/templates/configurators/main.hamlet b/templates/configurators/main.hamlet index 20ce9ed256..7e2132d1f8 100644 --- a/templates/configurators/main.hamlet +++ b/templates/configurators/main.hamlet @@ -4,9 +4,9 @@

Manage repositories -

- Distribute the files in this repository to other devices, # - make backups, and more, by adding repositories. +

+ Distribute the files in this repository to other devices, # + make backups, and more, by adding repositories.

$if xmppconfigured

@@ -21,4 +21,10 @@ Configure jabber account

Keep in touch with remote devices, and with your friends, # - by configuring a jabber account. +