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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue