try to drop unused object if it does not need to be transferred anywhere

This commit is contained in:
Joey Hess 2014-01-23 16:51:16 -04:00
parent 3518c586cf
commit 964a181026
4 changed files with 22 additions and 13 deletions

View file

@ -17,6 +17,7 @@ import Assistant.Common
import Assistant.DaemonStatus
import Assistant.Alert
import Assistant.Repair
import Assistant.Drop
import Assistant.Ssh
import Assistant.TransferQueue
import Assistant.Types.UrlRenderer
@ -94,11 +95,11 @@ sanityCheckerHourlyThread = namedThread "SanityCheckerHourly" $ forever $ do
{- This thread wakes up daily to make sure the tree is in good shape. -}
sanityCheckerDailyThread :: UrlRenderer -> NamedThread
sanityCheckerDailyThread urlrenderer = namedThread "SanityCheckerDaily" $ forever $ do
waitForNextCheck
debug ["starting sanity check"]
void $ alertWhile sanityCheckAlert go
debug ["sanity check complete"]
waitForNextCheck
where
go = do
modifyDaemonStatus_ $ \s -> s { sanityCheckRunning = True }
@ -172,11 +173,12 @@ dailyCheck urlrenderer = do
let (program', params') = batchmaker (program, [Param "unused"])
void $ liftIO $ boolSystem program' params'
{- Invalidate unused keys cache, and queue transfers of all unused
- keys. -}
- keys, or if no transfers are called for, drop them. -}
unused <- liftAnnex unusedKeys'
void $ liftAnnex $ setUnusedKeys unused
forM_ unused $ \k ->
queueTransfers "unused" Later k Nothing Upload
forM_ unused $ \k -> do
unlessM (queueTransfers "unused" Later k Nothing Upload) $
handleDrops "unused" True k Nothing Nothing
return True
where