add exporter thread to assistant

This is similar to the pusher thread, but a separate thread because git
pushes can be done in parallel with exports, and updating a big export
should not prevent other git pushes going out in the meantime.

The exportThread only runs at most every 30 seconds, since updating an
export is more expensive than pushing. This may need to be tuned.

Added a separate channel for export commits; the committer records a
commit in that channel.

Also, reconnectRemotes records a dummy commit, to make the exporter
thread wake up and make sure all exports are up-to-date. So,
connecting a drive with a directory special remote export will
immediately update it, and getting online will automatically
update S3 and WebDAV exports.

The transfer queue is not involved in exports. Instead, failed
exports are retried much like failed pushes.

This commit was sponsored by Ewen McNeill.

4 files changed, 83 insertions, 2 deletions

diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs
index 3680349be..aa57d26a8 100644
--- a/Assistant/Threads/Committer.hs
+++ b/Assistant/Threads/Committer.hs
@@ -67,6 +67,7 @@ commitThread = namedThread "Committer" $ do
 				void $ alertWhile commitAlert $
 					liftAnnex $ commitStaged msg
 				recordCommit
+				recordExportCommit
 				let numchanges = length readychanges
 				mapM_ checkChangeContent readychanges
 				return numchanges
diff --git a/Assistant/Threads/Exporter.hs b/Assistant/Threads/Exporter.hs
new file mode 100644
index 000000000..747e919da
--- /dev/null
+++ b/Assistant/Threads/Exporter.hs
@@ -0,0 +1,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
diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs
index 5b4055885..82bd39d89 100644
--- a/Assistant/Threads/Pusher.hs
+++ b/Assistant/Threads/Pusher.hs
@@ -22,6 +22,7 @@ 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
diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs
index fd77b88d2..e76c0b4fb 100644
--- a/Assistant/Threads/TransferScanner.hs
+++ b/Assistant/Threads/TransferScanner.hs
@@ -59,8 +59,9 @@ transferScannerThread urlrenderer = namedThread "TransferScanner" $ do
 			(s { transferScanRunning = b }, s)
 		liftIO $ sendNotification $ transferNotifier ds
 		
-	{- All git remotes are synced, and all available remotes
-	 - are scanned in full on startup, for multiple reasons, including:
+	{- All git remotes are synced, all exports are updated,
+	 - and all available remotes are scanned in full on startup,
+	 - for multiple reasons, including:
 	 -
 	 - * This may be the first run, and there may be remotes
 	 -   already in place, that need to be synced.