83056e7b53
Every remote that sets localpath also implements an availability that reutrns Unavailable when a local directory is not available. This makes external remotes, and others that get support for availability Unavailable to be used by checkAvailable. (Which is only used by the assistant.) Had to keep localpath though, since other parts of the assistant use it to eg, sync with a remote when a removable drive is plugged in. Sponsored-by: Jack Hill on Patreon
50 lines
1.7 KiB
Haskell
50 lines
1.7 KiB
Haskell
{- git-annex assistant git pushing thread
|
|
-
|
|
- Copyright 2012 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL 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)
|
|
=<< getAssistant failedPushMap
|
|
unless (null topush) $ do
|
|
debug ["retrying", show (length topush), "failed pushes"]
|
|
void $ pushToRemotes 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 =<< 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 = liftAnnex . filterM (Remote.checkAvailable True)
|
|
=<< candidates <$> getDaemonStatus
|
|
where
|
|
candidates = filter (not . Remote.readonly) . syncGitRemotes
|