a7821c0581
Added a RemoteChecker thread, that waits for problems to be reported with remotes, and checks if their git repository is in need of repair. Currently, only failures to sync with the remote cause a problem to be reported. This seems enough, but we'll see. Plugging in a removable drive with a repository on it that is corrupted does automatically repair the repository, as long as the corruption causes git push or git pull to fail. Some types of corruption do not, eg missing/corrupt objects for blobs that git push doesn't need to look at. So, this is not really a replacement for scheduled git repository fscking. But it does make the assistant more robust. This commit is sponsored by Fernando Jimenez.
49 lines
1.6 KiB
Haskell
49 lines
1.6 KiB
Haskell
{- git-annex assistant git pushing thread
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Assistant.Threads.Pusher where
|
|
|
|
import Assistant.Common
|
|
import Assistant.Commits
|
|
import Assistant.Pushes
|
|
import Assistant.DaemonStatus
|
|
import Assistant.Sync
|
|
import Utility.ThreadScheduler
|
|
import qualified Remote
|
|
import qualified Types.Remote as Remote
|
|
|
|
{- This thread retries pushes that failed before. -}
|
|
pushRetryThread :: NamedThread
|
|
pushRetryThread = namedThread "PushRetrier" $ runEvery (Seconds halfhour) <~> do
|
|
-- We already waited half an hour, now wait until there are failed
|
|
-- pushes to retry.
|
|
topush <- getFailedPushesBefore (fromIntegral halfhour)
|
|
unless (null topush) $ do
|
|
debug ["retrying", show (length topush), "failed pushes"]
|
|
void $ pushToRemotes True topush
|
|
where
|
|
halfhour = 1800
|
|
|
|
{- This thread pushes git commits out to remotes soon after they are made. -}
|
|
pushThread :: NamedThread
|
|
pushThread = namedThread "Pusher" $ runEvery (Seconds 2) <~> do
|
|
-- We already waited two seconds as a simple rate limiter.
|
|
-- Next, wait until at least one commit has been made
|
|
void getCommits
|
|
-- Now see if now's a good time to push.
|
|
void $ pushToRemotes True =<< pushTargets
|
|
|
|
{- We want to avoid pushing to remotes that are marked readonly.
|
|
-
|
|
- Also, avoid pushing to local remotes we can easily tell are not available,
|
|
- to avoid ugly messages when a removable drive is not attached.
|
|
-}
|
|
pushTargets :: Assistant [Remote]
|
|
pushTargets = liftIO . filterM (Remote.checkAvailable True)
|
|
=<< candidates <$> getDaemonStatus
|
|
where
|
|
candidates = filter (not . Remote.readonly) . syncGitRemotes
|