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.
This commit is contained in:
Joey Hess 2017-09-20 14:37:20 -04:00
parent 46d19648ee
commit d71c65ca0a
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
13 changed files with 124 additions and 22 deletions

View file

@ -17,24 +17,21 @@ import qualified Data.Map as M
{- Blocks until there are failed pushes.
- Returns Remotes whose pushes failed a given time duration or more ago.
- (This may be an empty list.) -}
getFailedPushesBefore :: NominalDiffTime -> Assistant [Remote]
getFailedPushesBefore duration = do
v <- getAssistant failedPushMap
liftIO $ do
m <- atomically $ readTMVar v
now <- getCurrentTime
return $ M.keys $ M.filter (not . toorecent now) m
getFailedPushesBefore :: NominalDiffTime -> FailedPushMap -> Assistant [Remote]
getFailedPushesBefore duration v = liftIO $ do
m <- atomically $ readTMVar v
now <- getCurrentTime
return $ M.keys $ M.filter (not . toorecent now) m
where
toorecent now time = now `diffUTCTime` time < duration
{- Modifies the map. -}
changeFailedPushMap :: (PushMap -> PushMap) -> Assistant ()
changeFailedPushMap a = do
v <- getAssistant failedPushMap
liftIO $ atomically $ store v . a . fromMaybe M.empty =<< tryTakeTMVar v
changeFailedPushMap :: FailedPushMap -> (PushMap -> PushMap) -> Assistant ()
changeFailedPushMap v f = liftIO $ atomically $
store . f . fromMaybe M.empty =<< tryTakeTMVar v
where
{- tryTakeTMVar empties the TMVar; refill it only if
- the modified map is not itself empty -}
store v m
store m
| m == M.empty = noop
| otherwise = putTMVar v $! m