40ecf58d4b
This does not change the overall license of the git-annex program, which was already AGPL due to a number of sources files being AGPL already. Legally speaking, I'm adding a new license under which these files are now available; I already released their current contents under the GPL license. Now they're dual licensed GPL and AGPL. However, I intend for all my future changes to these files to only be released under the AGPL license, and I won't be tracking the dual licensing status, so I'm simply changing the license statement to say it's AGPL. (In some cases, others wrote parts of the code of a file and released it under the GPL; but in all cases I have contributed a significant portion of the code in each file and it's that code that is getting the AGPL license; the GPL license of other contributors allows combining with AGPL code.)
80 lines
2.7 KiB
Haskell
80 lines
2.7 KiB
Haskell
{- git-annex assistant export updating thread
|
|
-
|
|
- Copyright 2017 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL 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 Annex.CurrentBranch
|
|
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 Nothing rs
|
|
=<< getCurrentBranch
|
|
-- 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
|