diff options
Diffstat (limited to 'Assistant')
| -rw-r--r-- | Assistant/Alert.hs | 19 | ||||
| -rw-r--r-- | Assistant/Threads/SanityChecker.hs | 105 | ||||
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 1 | ||||
| -rw-r--r-- | Assistant/TransferQueue.hs | 2 | ||||
| -rw-r--r-- | Assistant/Types/Alert.hs | 1 |
5 files changed, 121 insertions, 7 deletions
diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index 055e66de5..b5ee706b8 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -260,6 +260,25 @@ upgradeFailedAlert :: String -> Alert upgradeFailedAlert msg = (errorAlert msg []) { alertHeader = Just $ fromString "Upgrade failed." } +unusedFilesAlert :: [AlertButton] -> String -> Alert +unusedFilesAlert buttons message = Alert + { alertHeader = Just $ fromString $ unwords + [ "Old and deleted files are piling up --" + , message + ] + , alertIcon = Just InfoIcon + , alertPriority = High + , alertButtons = buttons + , alertClosable = True + , alertClass = Message + , alertMessageRender = renderData + , alertCounter = 0 + , alertBlockDisplay = True + , alertName = Just UnusedFilesAlert + , alertCombiner = Just $ fullCombiner $ \new _old -> new + , alertData = [] + } + brokenRepositoryAlert :: [AlertButton] -> Alert brokenRepositoryAlert = errorAlert "Serious problems have been detected with your repository. This needs your immediate attention!" diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index a1be8dffc..07d46ff84 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Assistant.Threads.SanityChecker ( sanityCheckerStartupThread, sanityCheckerDailyThread, @@ -16,7 +18,10 @@ import Assistant.DaemonStatus import Assistant.Alert import Assistant.Repair 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 @@ -25,12 +30,26 @@ 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 Git.Repair import Git.Index +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 - to finish. (However, the webapp thread does not, to prevent the UI @@ -78,8 +97,8 @@ sanityCheckerHourlyThread = namedThread "SanityCheckerHourly" $ forever $ do hourlyCheck {- This thread wakes up daily to make sure the tree is in good shape. -} -sanityCheckerDailyThread :: NamedThread -sanityCheckerDailyThread = namedThread "SanityCheckerDaily" $ forever $ do +sanityCheckerDailyThread :: UrlRenderer -> NamedThread +sanityCheckerDailyThread urlrenderer = namedThread "SanityCheckerDaily" $ forever $ do waitForNextCheck debug ["starting sanity check"] @@ -90,7 +109,8 @@ sanityCheckerDailyThread = namedThread "SanityCheckerDaily" $ forever $ do modifyDaemonStatus_ $ \s -> s { sanityCheckRunning = True } now <- liftIO getPOSIXTime -- before check started - r <- either showerr return =<< (tryIO . batch) <~> dailyCheck + r <- either showerr return + =<< (tryIO . batch) <~> dailyCheck urlrenderer modifyDaemonStatus_ $ \s -> s { sanityCheckRunning = False @@ -119,8 +139,8 @@ waitForNextCheck = do {- It's important to stay out of the Annex monad as much as possible while - running potentially expensive parts of this check, since remaining in it - will block the watcher. -} -dailyCheck :: Assistant Bool -dailyCheck = do +dailyCheck :: UrlRenderer -> Assistant Bool +dailyCheck urlrenderer = do g <- liftAnnex gitRepo batchmaker <- liftIO getBatchCommandMaker @@ -147,6 +167,22 @@ dailyCheck = do , Param "--auto" ] g + {- Check if the unused files found last time have been dealt with. -} + checkOldUnused urlrenderer + + {- Run git-annex unused once per day. This is run as a separate + - process to stay out of the annex monad and so it can run as a + - batch job. -} + program <- liftIO readProgramFile + let (program', params') = batchmaker (program, [Param "unused"]) + void $ liftIO $ boolSystem program' params' + {- Invalidate unused keys cache, and queue transfers of all unused + - keys. -} + unused <- liftAnnex unusedKeys' + void $ liftAnnex $ setUnusedKeys unused + forM_ unused $ \k -> + queueTransfers "unused" Later k Nothing Upload + return True where toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime) @@ -160,7 +196,8 @@ dailyCheck = do insanity $ "found unstaged symlink: " ++ file hourlyCheck :: Assistant () -hourlyCheck = checkLogSize 0 +hourlyCheck = do + checkLogSize 0 {- Rotate logs until log file size is < 1 mb. -} checkLogSize :: Int -> Assistant () @@ -185,3 +222,59 @@ oneHour = 60 * 60 oneDay :: Int oneDay = 24 * oneHour +{- If annex.expireunused is set, find any keys that have lingered unused + - 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. -} +checkOldUnused :: UrlRenderer -> Assistant () +checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGitConfig + where + go (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 + + prompt msg = +#ifdef WITH_WEBAPP + do + button <- mkAlertButton True (T.pack "Fix This") urlrenderer ConfigUnusedR + void $ addAlert $ unusedFilesAlert [button] msg +#else + debug [msg] +#endif diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index a7f9cc5b2..d2c2afd47 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -27,6 +27,7 @@ import Assistant.WebApp.Configurators.IA import Assistant.WebApp.Configurators.WebDAV import Assistant.WebApp.Configurators.XMPP import Assistant.WebApp.Configurators.Preferences +import Assistant.WebApp.Configurators.Unused import Assistant.WebApp.Configurators.Edit import Assistant.WebApp.Configurators.Delete import Assistant.WebApp.Configurators.Fsck diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs index 98fb2f06c..6d8e72852 100644 --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -1,6 +1,6 @@ {- git-annex assistant pending transfer queue - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012-2014 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Types/Alert.hs b/Assistant/Types/Alert.hs index e6fbe86d3..19fe55e6e 100644 --- a/Assistant/Types/Alert.hs +++ b/Assistant/Types/Alert.hs @@ -32,6 +32,7 @@ data AlertName | SyncAlert | NotFsckedAlert | UpgradeAlert + | UnusedFilesAlert deriving (Eq) {- The first alert is the new alert, the second is an old alert. |