add webapp UI to manage unused files
This commit is contained in:
Joey Hess
parent
9418685b5d
commit
e0bd088f08
11 changed files with 243 additions and 78 deletions
|
|
@ -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.
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
- than the remaining free disk space, or more than 1/10th the total
|
||||
- disk space being unused keys all suggest a problem. -}
|
||||
- know. -}
|
||||
checkOldUnused :: UrlRenderer -> Assistant ()
|
||||
checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGitConfig
|
||||
where
|
||||
go (Just Nothing) = noop
|
||||
go (Just (Just expireunused)) = do
|
||||
m <- liftAnnex $ readUnusedLog ""
|
||||
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
|
||||
go (Just (Just expireunused)) = expireUnused (Just expireunused)
|
||||
go Nothing = maybe noop prompt =<< describeUnusedWhenBig
|
||||
|
||||
prompt msg =
|
||||
#ifdef WITH_WEBAPP
|
||||
do
|
||||
button <- mkAlertButton True (T.pack "Fix This") urlrenderer ConfigUnusedR
|
||||
void $ addAlert $ unusedFilesAlert [button] msg
|
||||
button <- mkAlertButton True (T.pack "Configure") urlrenderer ConfigUnusedR
|
||||
void $ addAlert $ unusedFilesAlert [button] $ T.unpack $ renderTense Present msg
|
||||
#else
|
||||
debug [msg]
|
||||
#endif
|
||||
|
|
|
|||
86
Assistant/Unused.hs
Normal file
86
Assistant/Unused.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -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 qualified Build.SysConfig
|
||||
import Logs.Unused
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
BIN
doc/assistant/unused.png
Normal file
BIN
doc/assistant/unused.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 49 KiB |
|
|
@ -14,25 +14,29 @@
|
|||
Tune the behavior of git-annex, including how many copies #
|
||||
to retain of each file, and how much disk space it can use.
|
||||
<div .row-fluid>
|
||||
<div .span4>
|
||||
$if xmppconfigured
|
||||
<h3>
|
||||
<a href="@{XMPPConfigR}">
|
||||
Re-configure jabber account
|
||||
<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
|
||||
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}">
|
||||
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
|
||||
<p>
|
||||
Keep in touch with remote devices, and with your friends, #
|
||||
by configuring a jabber account.
|
||||
|
|
|
|||
38
templates/configurators/unused.hamlet
Normal file
38
templates/configurators/unused.hamlet
Normal file
|
|
@ -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
|
||||
6
templates/configurators/unused/form.hamlet
Normal file
6
templates/configurators/unused/form.hamlet
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
#{msg}
|
||||
<p>
|
||||
<div .input-prepend .input-append>
|
||||
^{fvInput enableView} after ^{fvInput whenView} days.
|
||||
<button type=submit .btn>
|
||||
Save Changes
|
||||
Loading…
Reference in a new issue