summaryrefslogtreecommitdiff
path: root/Assistant/Threads
diff options
context:
space:
mode:
Diffstat (limited to 'Assistant/Threads')
-rw-r--r--Assistant/Threads/Cronner.hs11
-rw-r--r--Assistant/Threads/TransferWatcher.hs29
-rw-r--r--Assistant/Threads/Transferrer.hs102
-rw-r--r--Assistant/Threads/Watcher.hs8
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