diff options
Diffstat (limited to 'Assistant/Threads')
-rw-r--r-- | Assistant/Threads/Cronner.hs | 11 | ||||
-rw-r--r-- | Assistant/Threads/TransferWatcher.hs | 29 | ||||
-rw-r--r-- | Assistant/Threads/Transferrer.hs | 102 | ||||
-rw-r--r-- | Assistant/Threads/Watcher.hs | 8 |
4 files changed, 9 insertions, 141 deletions
diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs index d0d277d77..b2be122d8 100644 --- a/Assistant/Threads/Cronner.hs +++ b/Assistant/Threads/Cronner.hs @@ -33,7 +33,7 @@ import Assistant.WebApp.Types #endif import Git.Remote (RemoteName) import qualified Git.Fsck -import Logs.FsckResults +import Assistant.Repair import Control.Concurrent.Async import Control.Concurrent.MVar @@ -189,12 +189,9 @@ runActivity' urlrenderer (ScheduledSelfFsck _ d) = do r <- Git.Fsck.findBroken True g void $ batchCommand program (Param "fsck" : annexFsckParams d) return r - when (Git.Fsck.foundBroken fsckresults) $ do - u <- liftAnnex getUUID - liftAnnex $ writeFsckResults u fsckresults - button <- mkAlertButton True (T.pack "Click Here") urlrenderer $ - RepairRepositoryR u - void $ addAlert $ brokenRepositoryAlert button + when (Git.Fsck.foundBroken fsckresults) $ + brokenRepositoryDetected fsckresults urlrenderer + =<< liftAnnex getUUID mapM_ reget =<< liftAnnex (dirKeys gitAnnexBadDir) where reget k = queueTransfers "fsck found bad file; redownloading" Next k Nothing Download diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs index 9bc851d4e..fc09373e7 100644 --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -9,9 +9,7 @@ module Assistant.Threads.TransferWatcher where import Assistant.Common import Assistant.DaemonStatus -import Assistant.TransferQueue -import Assistant.Drop -import Annex.Content +import Assistant.TransferSlots import Logs.Transfer import Utility.DirWatcher import Utility.DirWatcher.Types @@ -98,28 +96,3 @@ onDel file = case parseTransferFile file of - runs. -} threadDelay 10000000 -- 10 seconds finished t minfo - -{- Queue uploads of files downloaded to us, spreading them - - out to other reachable remotes. - - - - Downloading a file may have caused a remote to not want it; - - so check for drops from remotes. - - - - Uploading a file may cause the local repo, or some other remote to not - - want it; handle that too. - -} -finishedTransfer :: Transfer -> Maybe TransferInfo -> Assistant () -finishedTransfer t (Just info) - | transferDirection t == Download = - whenM (liftAnnex $ inAnnex $ transferKey t) $ do - dodrops False - queueTransfersMatching (/= transferUUID t) - "newly received object" - Later (transferKey t) (associatedFile info) Upload - | otherwise = dodrops True - where - dodrops fromhere = handleDrops - ("drop wanted after " ++ describeTransfer t info) - fromhere (transferKey t) (associatedFile info) Nothing -finishedTransfer _ _ = noop - diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs index 98f8b6ad7..82f3f3e10 100644 --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -36,105 +36,3 @@ transfererThread = namedThread "Transferrer" $ do where {- Skip transfers that are already running. -} notrunning = isNothing . startedTime - -{- By the time this is called, the daemonstatus's currentTransfers map should - - already have been updated to include the transfer. -} -genTransfer :: Transfer -> TransferInfo -> TransferGenerator -genTransfer t info = case (transferRemote info, associatedFile info) of - (Just remote, Just file) - | Git.repoIsLocalUnknown (Remote.repo remote) -> do - -- optimisation for removable drives not plugged in - liftAnnex $ recordFailedTransfer t info - void $ removeTransfer t - return Nothing - | otherwise -> ifM (liftAnnex $ shouldTransfer t info) - ( do - debug [ "Transferring:" , describeTransfer t info ] - notifyTransfer - return $ Just (t, info, go remote file) - , do - debug [ "Skipping unnecessary transfer:", - describeTransfer t info ] - void $ removeTransfer t - finishedTransfer t (Just info) - return Nothing - ) - _ -> return Nothing - where - direction = transferDirection t - isdownload = direction == Download - - {- Alerts are only shown for successful transfers. - - Transfers can temporarily fail for many reasons, - - so there's no point in bothering the user about - - those. The assistant should recover. - - - - After a successful upload, handle dropping it from - - here, if desired. In this case, the remote it was - - uploaded to is known to have it. - - - - Also, after a successful transfer, the location - - log has changed. Indicate that a commit has been - - made, in order to queue a push of the git-annex - - branch out to remotes that did not participate - - in the transfer. - - - - If the process failed, it could have crashed, - - so remove the transfer from the list of current - - transfers, just in case it didn't stop - - in a way that lets the TransferWatcher do its - - usual cleanup. However, first check if something else is - - running the transfer, to avoid removing active transfers. - -} - go remote file transferrer = ifM (liftIO $ performTransfer transferrer t $ associatedFile info) - ( do - void $ addAlert $ makeAlertFiller True $ - transferFileAlert direction True file - unless isdownload $ - handleDrops - ("object uploaded to " ++ show remote) - True (transferKey t) - (associatedFile info) - (Just remote) - void recordCommit - , whenM (liftAnnex $ isNothing <$> checkTransfer t) $ - void $ removeTransfer t - ) - -{- Called right before a transfer begins, this is a last chance to avoid - - unnecessary transfers. - - - - For downloads, we obviously don't need to download if the already - - have the object. - - - - Smilarly, for uploads, check if the remote is known to already have - - the object. - - - - Also, uploads get queued to all remotes, in order of cost. - - This may mean, for example, that an object is uploaded over the LAN - - to a locally paired client, and once that upload is done, a more - - expensive transfer remote no longer wants the object. (Since - - all the clients have it already.) So do one last check if this is still - - preferred content. - - - - We'll also do one last preferred content check for downloads. An - - example of a case where this could be needed is if a download is queued - - for a file that gets moved out of an archive directory -- but before - - that download can happen, the file is put back in the archive. - -} -shouldTransfer :: Transfer -> TransferInfo -> Annex Bool -shouldTransfer t info - | transferDirection t == Download = - (not <$> inAnnex key) <&&> wantGet True file - | transferDirection t == Upload = case transferRemote info of - Nothing -> return False - Just r -> notinremote r - <&&> wantSend True file (Remote.uuid r) - | otherwise = return False - where - key = transferKey t - file = associatedFile info - - {- Trust the location log to check if the remote already has - - the key. This avoids a roundtrip to the remote. -} - notinremote r = notElem (Remote.uuid r) <$> loggedLocations key diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index a44664639..3eedbe145 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -9,7 +9,7 @@ module Assistant.Threads.Watcher ( watchThread, - WatcherException(..), + WatcherControl(..), checkCanWatch, needLsof, onAddSymlink, @@ -64,10 +64,10 @@ needLsof = error $ unlines ] {- A special exception that can be thrown to pause or resume the watcher. -} -data WatcherException = PauseWatcher | ResumeWatcher +data WatcherControl = PauseWatcher | ResumeWatcher deriving (Show, Eq, Typeable) -instance E.Exception WatcherException +instance E.Exception WatcherControl watchThread :: NamedThread watchThread = namedThread "Watcher" $ @@ -107,7 +107,7 @@ runWatcher = do where hook a = Just <$> asIO2 (runHandler a) -waitFor :: WatcherException -> Assistant () -> Assistant () +waitFor :: WatcherControl -> Assistant () -> Assistant () waitFor sig next = do r <- liftIO (E.try pause :: IO (Either E.SomeException ())) case r of |