blob: 747e919da7aea82043108e4f181efc54e46c7c26 (
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
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
|
{- git-annex assistant export updating thread
-
- Copyright 2017 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Threads.Exporter where
import Assistant.Common
import Assistant.Commits
import Assistant.Pushes
import Assistant.DaemonStatus
import Annex.Concurrent
import Utility.ThreadScheduler
import qualified Annex
import qualified Remote
import qualified Types.Remote as Remote
import qualified Command.Sync
import Control.Concurrent.Async
import Data.Time.Clock
import qualified Data.Map as M
{- This thread retries exports that failed before. -}
exportRetryThread :: NamedThread
exportRetryThread = namedThread "ExportRetrier" $ runEvery (Seconds halfhour) <~> do
-- We already waited half an hour, now wait until there are failed
-- exports to retry.
toexport <- getFailedPushesBefore (fromIntegral halfhour)
=<< getAssistant failedExportMap
unless (null toexport) $ do
debug ["retrying", show (length toexport), "failed exports"]
void $ exportToRemotes toexport
where
halfhour = 1800
{- This thread updates exports soon after git commits are made. -}
exportThread :: NamedThread
exportThread = namedThread "Exporter" $ runEvery (Seconds 30) <~> do
-- We already waited two seconds as a simple rate limiter.
-- Next, wait until at least one commit has been made
void getExportCommits
-- Now see if now's a good time to push.
void $ exportToRemotes =<< exportTargets
{- We want to avoid exporting to remotes that are marked readonly.
-
- Also, avoid exporting to local remotes we can easily tell are not available,
- to avoid ugly messages when a removable drive is not attached.
-}
exportTargets :: Assistant [Remote]
exportTargets = liftIO . filterM (Remote.checkAvailable True)
=<< candidates <$> getDaemonStatus
where
candidates = filter (not . Remote.readonly) . exportRemotes
exportToRemotes :: [Remote] -> Assistant ()
exportToRemotes rs = do
-- This is a long-duration action which runs in the Annex monad,
-- so don't just liftAnnex to run it; fork the Annex state.
runner <- liftAnnex $ forkState $
forM rs $ \r -> do
Annex.changeState $ \st -> st { Annex.errcounter = 0 }
start <- liftIO getCurrentTime
void $ Command.Sync.seekExportContent rs
-- Look at command error counter to see if the export
-- didn't work.
failed <- (> 0) <$> Annex.getState Annex.errcounter
Annex.changeState $ \st -> st { Annex.errcounter = 0 }
return $ if failed
then Just (r, start)
else Nothing
failed <- catMaybes
<$> (liftAnnex =<< liftIO . wait =<< liftIO (async runner))
unless (null failed) $ do
v <- getAssistant failedExportMap
changeFailedPushMap v $ M.union $ M.fromList failed
|
