add webapp UI to manage unused files

Assistant/Alert.hs

@@ -1,6 +1,6 @@
 {- git-annex assistant alerts
  -
- - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}

Assistant/Threads/SanityChecker.hs

@@ -21,7 +21,6 @@ import Assistant.Ssh
 import Assistant.TransferQueue
 import Assistant.Types.UrlRenderer
 import qualified Annex.Branch
-import qualified Git
 import qualified Git.LsFiles
 import qualified Git.Command
 import qualified Git.Config
@@ -30,25 +29,21 @@ import qualified Assistant.Threads.Watcher as Watcher
 import Utility.LogFile
 import Utility.Batch
 import Utility.NotificationBroadcaster
-import Utility.DiskFree
 import Config
 import Utility.HumanTime
-import Utility.DataUnits
+import Utility.Tense
 import Git.Repair
 import Git.Index
+import Assistant.Unused
 import Logs.Unused
-import Logs.Location
 import Logs.Transfer
-import Annex.Content
 import Config.Files
-import Types.Key
 import qualified Annex
 #ifdef WITH_WEBAPP
 import Assistant.WebApp.Types
 #endif
 
 import Data.Time.Clock.POSIX
-import qualified Data.Map as M
 import qualified Data.Text as T
 
 {- This thread runs once at startup, and most other threads wait for it
@@ -226,56 +221,19 @@ oneDay = 24 * oneHour
  - for the specified duration, and remove them.
  -
  - Otherwise, check to see if unused keys are piling up, and let the user
- - know. This uses heuristics: 1000 unused keys, or more unused keys 
+ - know. -}
- - than the remaining free disk space, or more than 1/10th the total
- - disk space being unused keys all suggest a problem. -}
 checkOldUnused :: UrlRenderer -> Assistant ()
 checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGitConfig
   where
 	go (Just Nothing) = noop
-  	go (Just (Just expireunused)) = do
+  	go (Just (Just expireunused)) = expireUnused (Just expireunused)
-		m <- liftAnnex $ readUnusedLog ""
+	go Nothing = maybe noop prompt =<< describeUnusedWhenBig
-		now <- liftIO getPOSIXTime
-		let duration = durationToPOSIXTime expireunused
-		let oldkeys = M.keys $ M.filter (tooold now duration) m
-		forM_ oldkeys $ \k -> do
-			debug ["removing old unused key", key2file k]
-			liftAnnex $ do
-				removeAnnex k
-				logStatus k InfoMissing
-	go Nothing = maybe noop prompt
-		=<< toobig =<< liftAnnex (readUnusedLog "")
-
-	tooold now duration (_, mt) =
-		maybe False (\t -> now - t >= duration) mt
-
-	toobig m = do
-		let num = M.size m
-		let diskused = foldl' sumkeysize 0 (M.keys m)
-		df <- forpath getDiskFree
-		disksize <- forpath getDiskSize
-		return $ if moreused df diskused || tenthused disksize diskused
-			then Just $ roughSize storageUnits False diskused ++
-				" is used by old files"
-			else if num > 1000
-				then Just $ show num ++ " old files exist"
-				else Nothing
-
-	moreused Nothing _ = False
-	moreused (Just df) used = df <= used
-
-	tenthused Nothing _ = False
-	tenthused (Just disksize) used = used >= disksize `div` 10
-
-	sumkeysize s k = s + fromMaybe 0 (keySize k)
-
-	forpath a = liftAnnex $ inRepo $ liftIO . a . Git.repoPath
 
 	prompt msg = 
 #ifdef WITH_WEBAPP
 		do
-			button <- mkAlertButton True (T.pack "Fix This") urlrenderer ConfigUnusedR
+			button <- mkAlertButton True (T.pack "Configure") urlrenderer ConfigUnusedR
-			void $ addAlert $ unusedFilesAlert [button] msg
+			void $ addAlert $ unusedFilesAlert [button] $ T.unpack $ renderTense Present msg
 #else
 		debug [msg]
 #endif

Assistant/Unused.hs

@@ -0,0 +1,86 @@
+{- git-annex assistant unused files
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE OverloadedStrings #-}
+
+module Assistant.Unused where
+
+import qualified Data.Map as M
+
+import Assistant.Common
+import qualified Git
+import Types.Key
+import Logs.Unused
+import Logs.Location
+import Annex.Content
+import Utility.DataUnits
+import Utility.DiskFree
+import Utility.HumanTime
+import Utility.Tense
+
+import Data.Time.Clock.POSIX
+import qualified Data.Text as T
+
+describeUnused :: Assistant (Maybe TenseText)
+describeUnused = describeUnused' False
+
+describeUnusedWhenBig :: Assistant (Maybe TenseText)
+describeUnusedWhenBig = describeUnused' True
+
+{- This uses heuristics: 1000 unused keys, or more unused keys 
+ - than the remaining free disk space, or more than 1/10th the total
+ - disk space being unused keys all suggest a problem. -}
+describeUnused' :: Bool -> Assistant (Maybe TenseText)
+describeUnused' whenbig = liftAnnex $ go =<< readUnusedLog ""
+  where
+	go m = do
+		let num = M.size m
+		let diskused = foldl' sumkeysize 0 (M.keys m)
+		df <- forpath getDiskFree
+		disksize <- forpath getDiskSize
+		return $ if num == 0
+			then Nothing
+			else if not whenbig || moreused df diskused || tenthused disksize diskused
+				then Just $ tenseWords
+					[ UnTensed $ T.pack $ roughSize storageUnits False diskused
+					, Tensed "are" "were"
+					, "taken up by unused files"
+					]
+				else if num > 1000
+					then Just $ tenseWords
+						[ UnTensed $ T.pack $ show num ++ " unused files"
+						, Tensed "exist" "existed"
+						]
+					else Nothing
+
+	moreused Nothing _ = False
+	moreused (Just df) used = df <= used
+
+	tenthused Nothing _ = False
+	tenthused (Just disksize) used = used >= disksize `div` 10
+
+	sumkeysize s k = s + fromMaybe 0 (keySize k)
+
+	forpath a = inRepo $ liftIO . a . Git.repoPath
+
+{- With a duration, expires all unused files that are older.
+ - With Nothing, expires *all* unused files. -}
+expireUnused :: Maybe Duration -> Assistant ()
+expireUnused duration = do
+	m <- liftAnnex $ readUnusedLog ""
+	now <- liftIO getPOSIXTime
+	let oldkeys = M.keys $ M.filter (tooold now) m
+	forM_ oldkeys $ \k -> do
+		debug ["removing old unused key", key2file k]
+		liftAnnex $ do
+			removeAnnex k
+			logStatus k InfoMissing
+  where
+	boundry = durationToPOSIXTime <$> duration
+	tooold now (_, mt) = case boundry of
+		Nothing -> True
+		Just b -> maybe False (\t -> now - t >= b) mt

Assistant/WebApp/Configurators/Unused.hs

@@ -11,20 +11,70 @@ module Assistant.WebApp.Configurators.Unused where
 
 import Assistant.WebApp.Common
 import qualified Annex
-import qualified Git
+import Utility.HumanTime
+import Assistant.Unused
 import Config
-import Config.Files
-import Config.NumCopies
-import Utility.DataUnits
 import Git.Config
-import Types.Distribution
+import Logs.Unused
-import qualified Build.SysConfig
+import Utility.Tense
 
-import qualified Data.Text as T
+import qualified Text.Hamlet as Hamlet
+
+data UnusedForm = UnusedForm
+	{ enableExpire :: Bool
+	, expireWhen :: Integer
+	}
+
+unusedForm :: UnusedForm -> Hamlet.Html -> MkMForm UnusedForm
+unusedForm def msg = do
+	(enableRes, enableView) <- mreq (selectFieldList enabledisable) ""
+		(Just $ enableExpire def)
+	(whenRes, whenView) <- mreq intField ""
+		(Just $ expireWhen def)
+	let form = do
+		webAppFormAuthToken
+		$(widgetFile "configurators/unused/form")
+	return (UnusedForm <$> enableRes <*> whenRes, form)
+  where
+	enabledisable :: [(Text, Bool)]
+	enabledisable = [("Disable expiry", False), ("Enable expiry", True)]
 
 getConfigUnusedR :: Handler Html
-getConfigUnusedR = error "TODO"
+getConfigUnusedR = postConfigUnusedR
-
 postConfigUnusedR :: Handler Html
-postConfigUnusedR = getConfigUnusedR
+postConfigUnusedR = page "Unused files" (Just Configuration) $ do
+	current <- liftAnnex getUnused
+	((res, form), enctype) <- liftH $ runFormPostNoToken $ unusedForm current
+	case res of
+		FormSuccess new -> liftH $ do
+			liftAnnex $ storeUnused new
+			redirect ConfigurationR
+		_ -> do
+			munuseddesc <- liftAssistant describeUnused
+			ts <- liftAnnex $ dateUnusedLog ""
+			mlastchecked <- case ts of
+				Nothing -> pure Nothing
+				Just t -> Just <$> liftIO (durationSince t)
+			$(widgetFile "configurators/unused")
 
+getUnused :: Annex UnusedForm
+getUnused = convert . annexExpireUnused <$> Annex.getGitConfig
+  where
+	convert Nothing = noexpire
+	convert (Just Nothing) = noexpire
+	convert (Just (Just n)) = UnusedForm True $ durationToDays n
+
+	-- The 7 is so that, if they enable expiry, they have to change
+	-- it to get faster than  a week.
+	noexpire = UnusedForm False 7
+
+storeUnused :: UnusedForm -> Annex ()
+storeUnused f = setConfig (annexConfig "expireunused") $
+	if not (enableExpire f) || expireWhen f < 0
+		then boolConfig False
+		else fromDuration $ daysToDuration $ expireWhen f
+
+getCleanupUnusedR :: Handler Html
+getCleanupUnusedR = do
+	liftAssistant $ expireUnused Nothing
+	redirect ConfigUnusedR

Assistant/WebApp/routes

@@ -25,7 +25,7 @@
 /config/upgrade/start/#GitAnnexDistribution ConfigStartUpgradeR GET
 /config/upgrade/finish ConfigFinishUpgradeR GET
 /config/upgrade/automatically ConfigEnableAutomaticUpgradeR GET
-/config/preferences/unused ConfigUnusedR GET POST
+/config/unused ConfigUnusedR GET POST
 
 /config/addrepository AddRepositoryR GET
 /config/repository/new NewRepositoryR GET POST
@@ -119,4 +119,6 @@
 /repair/#UUID RepairRepositoryR GET POST
 /repair/run/#UUID RepairRepositoryRunR GET POST
 
+/unused/cleanup CleanupUnusedR GET
+
 /static StaticR Static getStatic

Logs/Unused.hs

@@ -20,9 +20,10 @@ module Logs.Unused (
 	updateUnusedLog,
 	readUnusedLog,
 	readUnusedMap,
+	dateUnusedLog,
 	unusedKeys,
+	unusedKeys',
 	setUnusedKeys,
-	unusedKeys'
 ) where
 
 import qualified Data.Map as M
@@ -88,6 +89,11 @@ readUnusedLog prefix = do
 readUnusedMap :: FilePath -> Annex UnusedMap
 readUnusedMap = log2map <$$> readUnusedLog
 
+dateUnusedLog :: FilePath -> Annex (Maybe UTCTime)
+dateUnusedLog prefix = do
+	f <- fromRepo $ gitAnnexUnusedLog prefix
+	liftIO $ catchMaybeIO $ getModificationTime f
+
 {- Set of unused keys. This is cached for speed. -}
 unusedKeys :: Annex (S.Set Key)
 unusedKeys = maybe (setUnusedKeys =<< unusedKeys') return

Utility/HumanTime.hs

@@ -7,7 +7,10 @@
 
 module Utility.HumanTime (
 	Duration(..),
+	durationSince,
 	durationToPOSIXTime,
+	durationToDays,
+	daysToDuration,
 	parseDuration,
 	fromDuration,
 	prop_duration_roundtrips
@@ -17,6 +20,7 @@ import Utility.PartialPrelude
 import Utility.Applicative
 import Utility.QuickCheck
 
+import Data.Time.Clock
 import Data.Time.Clock.POSIX (POSIXTime)
 import Data.Char
 import Control.Applicative
@@ -25,9 +29,20 @@ import qualified Data.Map as M
 newtype Duration = Duration { durationSeconds :: Integer }
   deriving (Eq, Ord, Read, Show)
 
+durationSince :: UTCTime -> IO Duration
+durationSince pasttime = do
+	now <- getCurrentTime
+	return $ Duration $ round $ diffUTCTime now pasttime
+
 durationToPOSIXTime :: Duration -> POSIXTime
 durationToPOSIXTime = fromIntegral . durationSeconds
 
+durationToDays :: Duration -> Integer
+durationToDays d = durationSeconds d `div` dsecs
+
+daysToDuration :: Integer -> Duration
+daysToDuration i = Duration $ i * dsecs
+
 {- Parses a human-input time duration, of the form "5h", "1m", "5h1m", etc -}
 parseDuration :: String -> Maybe Duration
 parseDuration = Duration <$$> go 0

templates/configurators/main.hamlet

@@ -15,24 +15,28 @@
         to retain of each file, and how much disk space it can use.
   <div .row-fluid>
     <div .span4>
-      $if xmppconfigured
+      <h3>
+        <a href="@{ConfigFsckR}">
+          Consistency checks
+      <p>
+        Set up periodic checks of your data to detect and recover from #
+        disk problems.
+    <div .span4>
+      <h3>
+        <a href="@{ConfigUnusedR}">
+          Unused files
+      <p>
+        Configure what to do with old and deleted files.
+  <div .row-fluid>
+    <div .span4>
       <h3>
         <a href="@{XMPPConfigR}">
-            Re-configure jabber account
+          Jabber account
+      $if xmppconfigured
         <p>
           Your jabber account is set up, and will be used to keep #
           in touch with remote devices, and with your friends.
       $else
-        <h3>
-          <a href="@{XMPPConfigR}">
-            Configure jabber account
         <p>
           Keep in touch with remote devices, and with your friends, #
           by configuring a jabber account.
-    <div .span4>
-      <h3>
-        <a href="@{ConfigFsckR}">
-          Configure consistency checks
-      <p>
-        Set up periodic checks of your data to detect and recover from #
-        disk problems.

templates/configurators/unused.hamlet

@@ -0,0 +1,38 @@
+<div .span9 .hero-unit>
+  <h2>
+    Managing unused files
+  <p>
+    $maybe desc <- munuseddesc
+      Some old versions of files and deleted files have been preserved #
+      inside this repository.
+      <div .alert .alert-info>
+        <i .icon-info-sign></i> #{renderTense Past desc} #
+        $maybe lastchecked <- mlastchecked
+          (last checked #{fromDuration lastchecked} ago)
+    $nothing
+      Old versions of files and deleted files can be preserved inside #
+      this repository.
+  <p>
+    This might be useful, if you ever need to access those old or deleted #
+    files. But they'll also use up disk space. There are three ways to deal #
+    with this.
+  <ol>
+    <li>
+      <p>
+        Set up a backup or archive repository, on a removable drive #
+        or in the cloud, and the unused files will be moved to it, freeing #
+        up space.
+        <br>
+        <a .btn href="@{AddRepositoryR}">
+          <i .icon-plus></i> Add a new repository
+    <li>
+      <p>
+        Or, you can let unused files expire after a period of time.
+        <form method="post" .form-inline enctype=#{enctype}>
+          ^{form}
+    <li>
+      <p>
+        Finally, you can clean up all unused files manually at any time.
+        <br>
+        <a .btn href="@{CleanupUnusedR}">
+          <i .icon-trash></i> Clean up unused files now

templates/configurators/unused/form.hamlet

@@ -0,0 +1,6 @@
+#{msg}
+<p>
+  <div .input-prepend .input-append>
+    ^{fvInput enableView} after ^{fvInput whenView} days.&nbsp;
+    <button type=submit .btn>
+      Save Changes