blob: 82bd39d893a1791eaca6403871bf136de5564d34 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
|
{- git-annex assistant git pushing thread
-
- Copyright 2012 Joey Hess <id@joeyh.name>
-
- 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)
=<< 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 = liftIO . filterM (Remote.checkAvailable True)
=<< candidates <$> getDaemonStatus
where
candidates = filter (not . Remote.readonly) . syncGitRemotes
|
