diff options
Diffstat (limited to 'Assistant')
| -rw-r--r-- | Assistant/DaemonStatus.hs | 30 | ||||
| -rw-r--r-- | Assistant/Drop.hs | 65 | ||||
| -rw-r--r-- | Assistant/MakeRemote.hs | 10 | ||||
| -rw-r--r-- | Assistant/Pairing/MakeRemote.hs | 2 | ||||
| -rw-r--r-- | Assistant/Sync.hs | 6 | ||||
| -rw-r--r-- | Assistant/Threads/Merger.hs | 2 | ||||
| -rw-r--r-- | Assistant/Threads/MountWatcher.hs | 2 | ||||
| -rw-r--r-- | Assistant/Threads/PairListener.hs | 12 | ||||
| -rw-r--r-- | Assistant/Threads/Pusher.hs | 2 | ||||
| -rw-r--r-- | Assistant/Threads/SanityChecker.hs | 2 | ||||
| -rw-r--r-- | Assistant/Threads/TransferPoller.hs | 2 | ||||
| -rw-r--r-- | Assistant/Threads/TransferScanner.hs | 62 | ||||
| -rw-r--r-- | Assistant/Threads/TransferWatcher.hs | 49 | ||||
| -rw-r--r-- | Assistant/Threads/Watcher.hs | 18 | ||||
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 5 | ||||
| -rw-r--r-- | Assistant/TransferQueue.hs | 35 |
16 files changed, 214 insertions, 90 deletions
diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index 11ea8676d..60b560b90 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -17,6 +17,8 @@ import Utility.NotificationBroadcaster import Logs.Transfer import Logs.Trust import qualified Remote +import qualified Types.Remote as Remote +import Config import Control.Concurrent.STM import System.Posix.Types @@ -39,8 +41,8 @@ data DaemonStatus = DaemonStatus -- Messages to display to the user. , alertMap :: AlertMap , lastAlertId :: AlertId - -- Ordered list of remotes to talk to. - , knownRemotes :: [Remote] + -- Ordered list of remotes to sync with. + , syncRemotes :: [Remote] -- Pairing request that is in progress. , pairingInProgress :: Maybe PairingInProgress -- Broadcasts notifications about all changes to the DaemonStatus @@ -86,21 +88,21 @@ modifyDaemonStatus dstatus a = do sendNotification $ changeNotifier s return b -{- Remotes ordered by cost, with dead ones thrown out. -} -calcKnownRemotes :: Annex [Remote] -calcKnownRemotes = do - rs <- concat . Remote.byCost <$> Remote.enabledRemoteList +{- Syncable remotes ordered by cost. -} +calcSyncRemotes :: Annex [Remote] +calcSyncRemotes = do + rs <- filterM (repoSyncable . Remote.repo) =<< + concat . Remote.byCost <$> Remote.enabledRemoteList alive <- snd <$> trustPartition DeadTrusted (map Remote.uuid rs) let good r = Remote.uuid r `elem` alive return $ filter good rs -{- Updates the cached ordered list of remotes from the list in Annex - - state. -} -updateKnownRemotes :: DaemonStatusHandle -> Annex () -updateKnownRemotes dstatus = do - remotes <- calcKnownRemotes +{- Updates the sycRemotes list from the list of all remotes in Annex state. -} +updateSyncRemotes :: DaemonStatusHandle -> Annex () +updateSyncRemotes dstatus = do + remotes <- calcSyncRemotes liftIO $ modifyDaemonStatus_ dstatus $ - \s -> s { knownRemotes = remotes } + \s -> s { syncRemotes = remotes } {- Load any previous daemon status file, and store it in a MVar for this - process to use as its DaemonStatus. Also gets current transfer status. -} @@ -110,12 +112,12 @@ startDaemonStatus = do status <- liftIO $ flip catchDefaultIO (readDaemonStatusFile file) =<< newDaemonStatus transfers <- M.fromList <$> getTransfers - remotes <- calcKnownRemotes + remotes <- calcSyncRemotes liftIO $ atomically $ newTMVar status { scanComplete = False , sanityCheckRunning = False , currentTransfers = transfers - , knownRemotes = remotes + , syncRemotes = remotes } {- Don't just dump out the structure, because it will change over time, diff --git a/Assistant/Drop.hs b/Assistant/Drop.hs new file mode 100644 index 000000000..cf20ef5b1 --- /dev/null +++ b/Assistant/Drop.hs @@ -0,0 +1,65 @@ +{- git-annex assistant dropping of unwanted content + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Drop where + +import Assistant.Common +import Assistant.DaemonStatus +import Logs.Location +import Logs.Trust +import Types.Remote (AssociatedFile) +import qualified Remote +import qualified Command.Drop +import Command +import Annex.Wanted +import Config + +{- Drop from local and/or remote when allowed by the preferred content and + - numcopies settings. -} +handleDrops :: DaemonStatusHandle -> Bool -> Key -> AssociatedFile -> Annex () +handleDrops _ _ _ Nothing = noop +handleDrops dstatus fromhere key f = do + syncrs <- liftIO $ syncRemotes <$> getDaemonStatus dstatus + locs <- loggedLocations key + handleDrops' locs syncrs fromhere key f + +handleDrops' :: [UUID] -> [Remote] -> Bool -> Key -> AssociatedFile -> Annex () +handleDrops' _ _ _ _ Nothing = noop +handleDrops' locs rs fromhere key (Just f) + | fromhere = do + n <- getcopies + if checkcopies n + then go rs =<< dropl n + else go rs n + | otherwise = go rs =<< getcopies + where + getcopies = do + have <- length . snd <$> trustPartition UnTrusted locs + numcopies <- getNumCopies =<< numCopies f + return (have, numcopies) + checkcopies (have, numcopies) = have > numcopies + decrcopies (have, numcopies) = (have - 1, numcopies) + + go [] _ = noop + go (r:rest) n + | checkcopies n = dropr r n >>= go rest + | otherwise = noop + + checkdrop n@(_, numcopies) u a = + ifM (wantDrop u (Just f)) + ( ifM (doCommand $ a (Just numcopies)) + ( return $ decrcopies n + , return n + ) + , return n + ) + + dropl n = checkdrop n Nothing $ \numcopies -> + Command.Drop.startLocal f numcopies key + + dropr r n = checkdrop n (Just $ Remote.uuid r) $ \numcopies -> + Command.Drop.startRemote f numcopies key r diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs index 9184cb529..8aa7cb2e8 100644 --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -28,11 +28,12 @@ import qualified Data.Map as M import Data.Char {- Sets up and begins syncing with a new ssh or rsync remote. -} -makeSshRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Bool -> SshData -> IO () +makeSshRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Bool -> SshData -> IO Remote makeSshRemote st dstatus scanremotes forcersync sshdata = do r <- runThreadState st $ addRemote $ maker (sshRepoName sshdata) sshurl syncNewRemote st dstatus scanremotes r + return r where rsync = forcersync || rsyncOnly sshdata maker @@ -89,10 +90,11 @@ makeGitRemote basename location = makeRemote basename location $ \name -> - Returns the name of the remote. -} makeRemote :: String -> String -> (String -> Annex ()) -> Annex String makeRemote basename location a = do - r <- fromRepo id - if not (any samelocation $ Git.remotes r) + g <- gitRepo + if not (any samelocation $ Git.remotes g) then do - let name = uniqueRemoteName basename 0 r + + let name = uniqueRemoteName basename 0 g a name return name else return basename diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs index fae8c5ee3..ab0bef13c 100644 --- a/Assistant/Pairing/MakeRemote.hs +++ b/Assistant/Pairing/MakeRemote.hs @@ -46,7 +46,7 @@ finishedPairing st dstatus scanremotes msg keypair = do , "git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata) ] "" - makeSshRemote st dstatus scanremotes False sshdata + void $ makeSshRemote st dstatus scanremotes False sshdata {- Mostly a straightforward conversion. Except: - * Determine the best hostname to use to contact the host. diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index 91ee1c219..6c167e2ea 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -84,7 +84,7 @@ reconnectRemotes threadname st dstatus scanremotes rs = void $ pushToRemotes :: ThreadName -> UTCTime -> ThreadState -> Maybe FailedPushMap -> [Remote] -> IO Bool pushToRemotes threadname now st mpushmap remotes = do (g, branch, u) <- runThreadState st $ (,,) - <$> fromRepo id + <$> gitRepo <*> inRepo Git.Branch.current <*> getUUID go True branch g u remotes @@ -145,7 +145,7 @@ pushToRemotes threadname now st mpushmap remotes = do {- Manually pull from remotes and merge their branches. -} manualPull :: ThreadState -> Maybe Git.Ref -> [Remote] -> IO Bool manualPull st currentbranch remotes = do - g <- runThreadState st $ fromRepo id + g <- runThreadState st gitRepo forM_ remotes $ \r -> Git.Command.runBool "fetch" [Param $ Remote.name r] g haddiverged <- runThreadState st Annex.Branch.forceUpdate @@ -156,5 +156,5 @@ manualPull st currentbranch remotes = do {- Start syncing a newly added remote, using a background thread. -} syncNewRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Remote -> IO () syncNewRemote st dstatus scanremotes remote = do - runThreadState st $ updateKnownRemotes dstatus + runThreadState st $ updateSyncRemotes dstatus void $ forkIO $ reconnectRemotes "SyncRemote" st dstatus scanremotes [remote] diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs index 0349bb1f0..46f516262 100644 --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -25,7 +25,7 @@ thisThread = "Merger" - pushes. -} mergeThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> NamedThread mergeThread st dstatus transferqueue = thread $ do - g <- runThreadState st $ fromRepo id + g <- runThreadState st gitRepo let dir = Git.localGitDir g </> "refs" createDirectoryIfMissing True dir let hook a = Just $ runHandler st dstatus transferqueue a diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index 79fcce08c..462f5843c 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -174,7 +174,7 @@ remotesUnder st dstatus dir = runThreadState st $ do let (waschanged, rs') = unzip pairs when (any id waschanged) $ do Annex.changeState $ \s -> s { Annex.remotes = rs' } - updateKnownRemotes dstatus + updateSyncRemotes dstatus return $ map snd $ filter fst pairs where checkremote repotop r = case Remote.localpath r of diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index 9ce369032..9875dcb8a 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -17,6 +17,7 @@ import Assistant.DaemonStatus import Assistant.WebApp import Assistant.WebApp.Types import Assistant.Alert +import Utility.ThreadScheduler import Network.Multicast import Network.Socket @@ -27,12 +28,17 @@ thisThread :: ThreadName thisThread = "PairListener" pairListenerThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> UrlRenderer -> NamedThread -pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $ do - sock <- multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort - go sock [] [] +pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $ + runEvery (Seconds 1) $ void $ tryIO $ do + sock <- getsock + go sock [] [] where thread = NamedThread thisThread + {- Note this can crash if there's no network interface, + - or only one like lo that doesn't support multicast. -} + getsock = multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort + go sock reqs cache = getmsg sock [] >>= \msg -> case readish msg of Nothing -> go sock reqs cache Just m -> do diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs index dee563d74..4f3a2dd09 100644 --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -52,7 +52,7 @@ pushThread st dstatus commitchan pushmap = thread $ runEvery (Seconds 2) $ do now <- getCurrentTime if shouldPush now commits then do - remotes <- filter pushable . knownRemotes + remotes <- filter pushable . syncRemotes <$> getDaemonStatus dstatus unless (null remotes) $ void $ alertWhile dstatus (pushAlert remotes) $ diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index f01b63de3..912270090 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -74,7 +74,7 @@ oneDay = 24 * 60 * 60 - will block the watcher. -} check :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO Bool check st dstatus transferqueue changechan = do - g <- runThreadState st $ fromRepo id + g <- runThreadState st gitRepo -- Find old unstaged symlinks, and add them to git. (unstaged, cleanup) <- Git.LsFiles.notInRepo False ["."] g now <- getPOSIXTime diff --git a/Assistant/Threads/TransferPoller.hs b/Assistant/Threads/TransferPoller.hs index 10ed7dd31..afead63ec 100644 --- a/Assistant/Threads/TransferPoller.hs +++ b/Assistant/Threads/TransferPoller.hs @@ -24,7 +24,7 @@ thisThread = "TransferPoller" - of each transfer is complete. -} transferPollerThread :: ThreadState -> DaemonStatusHandle -> NamedThread transferPollerThread st dstatus = thread $ do - g <- runThreadState st $ fromRepo id + g <- runThreadState st gitRepo tn <- newNotificationHandle =<< transferNotifier <$> getDaemonStatus dstatus forever $ do diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs index cb02ed2f2..631c36b02 100644 --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -13,6 +13,7 @@ import Assistant.TransferQueue import Assistant.ThreadedMonad import Assistant.DaemonStatus import Assistant.Alert +import Assistant.Drop import Logs.Transfer import Logs.Location import Logs.Web (webUUID) @@ -22,6 +23,7 @@ import Utility.ThreadScheduler import qualified Git.LsFiles as LsFiles import Command import Annex.Content +import Annex.Wanted import qualified Data.Set as S @@ -60,7 +62,7 @@ transferScannerThread st dstatus scanremotes transferqueue = thread $ do - lost. -} startupScan = addScanRemotes scanremotes True - =<< knownRemotes <$> getDaemonStatus dstatus + =<< syncRemotes <$> getDaemonStatus dstatus {- This is a cheap scan for failed transfers involving a remote. -} failedTransferScan :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Remote -> IO () @@ -86,16 +88,26 @@ failedTransferScan st dstatus transferqueue r = do transferqueue dstatus (associatedFile info) t r {- This is a expensive scan through the full git work tree, finding - - files to download from or upload to any of the remotes. - - - - The scan is blocked when the transfer queue gets too large. -} + - files to transfer. The scan is blocked when the transfer queue gets + - too large. + - + - This also finds files that are present either here or on a remote + - but that are not preferred content, and drops them. Searching for files + - to drop is done concurrently with the scan for transfers. + - + - TODO: It would be better to first drop as much as we can, before + - transferring much, to minimise disk use. + -} expensiveScan :: ThreadState -> DaemonStatusHandle -> TransferQueue -> [Remote] -> IO () expensiveScan st dstatus transferqueue rs = unless onlyweb $ do liftIO $ debug thisThread ["starting scan of", show visiblers] void $ alertWhile dstatus (scanAlert visiblers) $ do - g <- runThreadState st $ fromRepo id + g <- runThreadState st gitRepo (files, cleanup) <- LsFiles.inRepo [] g - go files + forM_ files $ \f -> do + ts <- runThreadState st $ + ifAnnexed f (findtransfers f) (return []) + mapM_ (enqueue f) ts void cleanup return True liftIO $ debug thisThread ["finished scan of", show visiblers] @@ -103,26 +115,32 @@ expensiveScan st dstatus transferqueue rs = unless onlyweb $ do onlyweb = all (== webUUID) $ map Remote.uuid rs visiblers = let rs' = filter (not . Remote.readonly) rs in if null rs' then rs else rs' - go [] = noop - go (f:fs) = do - mapM_ (enqueue f) =<< catMaybes <$> runThreadState st - (ifAnnexed f findtransfers $ return []) - go fs enqueue f (r, t) = do debug thisThread ["queuing", show t] queueTransferWhenSmall transferqueue dstatus (Just f) t r - findtransfers (key, _) = do + findtransfers f (key, _) = do locs <- loggedLocations key - let use a = return $ map (a key locs) rs - ifM (inAnnex key) - ( use $ check Upload False - , use $ check Download True - ) - check direction want key locs r - | direction == Upload && Remote.readonly r = Nothing - | (Remote.uuid r `elem` locs) == want = Just - (r, Transfer direction (Remote.uuid r) key) - | otherwise = Nothing + {- The syncable remotes may have changed since this + - scan began. -} + syncrs <- liftIO $ syncRemotes <$> getDaemonStatus dstatus + present <- inAnnex key + + handleDrops' locs syncrs present key (Just f) + + let slocs = S.fromList locs + let use a = return $ catMaybes $ map (a key slocs) syncrs + if present + then filterM (wantSend (Just f) . Remote.uuid . fst) + =<< use (genTransfer Upload False) + else ifM (wantGet $ Just f) + ( use (genTransfer Download True) , return [] ) + +genTransfer :: Direction -> Bool -> Key -> S.Set UUID -> Remote -> Maybe (Remote, Transfer) +genTransfer direction want key slocs r + | direction == Upload && Remote.readonly r = Nothing + | (S.member (Remote.uuid r) slocs) == want = Just + (r, Transfer direction (Remote.uuid r) key) + | otherwise = Nothing remoteHas :: Remote -> Key -> Annex Bool remoteHas r key = elem diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs index 33f0dacbe..168ff2688 100644 --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -11,12 +11,15 @@ import Assistant.Common import Assistant.ThreadedMonad import Assistant.DaemonStatus import Assistant.TransferQueue +import Assistant.Drop import Annex.Content import Logs.Transfer import Utility.DirWatcher import Utility.Types.DirWatcher import qualified Remote +import Control.Concurrent + thisThread :: ThreadName thisThread = "TransferWatcher" @@ -24,7 +27,7 @@ thisThread = "TransferWatcher" - and updates the DaemonStatus's map of ongoing transfers. -} transferWatcherThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> NamedThread transferWatcherThread st dstatus transferqueue = thread $ do - g <- runThreadState st $ fromRepo id + g <- runThreadState st gitRepo let dir = gitAnnexTransferDir g createDirectoryIfMissing True dir let hook a = Just $ runHandler st dstatus transferqueue a @@ -67,8 +70,8 @@ onAdd st dstatus _ file _ = case parseTransferFile file of [ "transfer starting:" , show t ] - r <- headMaybe . filter (sameuuid t) . knownRemotes - <$> getDaemonStatus dstatus + r <- headMaybe . filter (sameuuid t) + <$> runThreadState st Remote.remoteList updateTransferInfo dstatus t info { transferRemote = r } sameuuid t r = Remote.uuid r == transferUUID t @@ -103,15 +106,31 @@ onDel st dstatus transferqueue file _ = case parseTransferFile file of ] minfo <- removeTransfer dstatus t - {- Queue uploads of files we successfully downloaded, - - spreading them out to other reachable remotes. -} - case (minfo, transferDirection t) of - (Just info, Download) -> runThreadState st $ - whenM (inAnnex $ transferKey t) $ - queueTransfersMatching - (/= transferUUID t) - Later transferqueue dstatus - (transferKey t) - (associatedFile info) - Upload - _ -> noop + void $ forkIO $ do + {- XXX race workaround delay. The location + - log needs to be updated before finishedTransfer + - runs. -} + threadDelay 10000000 -- 10 seconds + finishedTransfer st dstatus transferqueue t minfo + +{- Queue uploads of files we successfully downloaded, spreading them + - out to other reachable remotes. + - + - Downloading a file may have caused a remote to not want it; + - so drop it from the remote. + - + - Uploading a file may cause the local repo, or some other remote to not + - want it; handle that too. + -} +finishedTransfer :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Transfer -> Maybe TransferInfo -> IO () +finishedTransfer st dstatus transferqueue t (Just info) + | transferDirection t == Download = runThreadState st $ + whenM (inAnnex $ transferKey t) $ do + handleDrops dstatus False + (transferKey t) (associatedFile info) + queueTransfersMatching (/= transferUUID t) + Later transferqueue dstatus + (transferKey t) (associatedFile info) Upload + | otherwise = runThreadState st $ + handleDrops dstatus True (transferKey t) (associatedFile info) +finishedTransfer _ _ _ _ _ = noop diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index 1bf9e8581..310a6e984 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -20,6 +20,7 @@ import Assistant.DaemonStatus import Assistant.Changes import Assistant.TransferQueue import Assistant.Alert +import Assistant.Drop import Logs.Transfer import Utility.DirWatcher import Utility.Types.DirWatcher @@ -135,6 +136,7 @@ onAddSymlink threadname file filestatus dstatus transferqueue = go =<< Backend.l liftIO $ debug threadname ["fix symlink", file] liftIO $ removeFile file liftIO $ createSymbolicLink link file + checkcontent key =<< liftIO (getDaemonStatus dstatus) addlink link ) go Nothing = do -- other symlink @@ -146,7 +148,7 @@ onAddSymlink threadname file filestatus dstatus transferqueue = go =<< Backend.l - and being re-added, or added when the watcher was - not running. So they're normally restaged to make sure. - - - As an optimisation, during the status scan, avoid + - As an optimisation, during the startup scan, avoid - restaging everything. Only links that were created since - the last time the daemon was running are staged. - (If the daemon has never ran before, avoid staging @@ -174,12 +176,16 @@ onAddSymlink threadname file filestatus dstatus transferqueue = go =<< Backend.l stageSymlink file sha madeChange file LinkChange - {- When a new link appears, after the startup scan, - - try to get the key's content. -} + {- When a new link appears, or a link is changed, + - after the startup scan, handle getting or + - dropping the key's content. -} checkcontent key daemonstatus - | scanComplete daemonstatus = unlessM (inAnnex key) $ - queueTransfers Next transferqueue dstatus - key (Just file) Download + | scanComplete daemonstatus = do + present <- inAnnex key + unless present $ + queueTransfers Next transferqueue dstatus + key (Just file) Download + handleDrops dstatus present key (Just file) | otherwise = noop onDel :: Handler diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index cb5f58b2d..c33dc2103 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -5,7 +5,7 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-} +{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes, CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Assistant.Threads.WebApp where @@ -17,10 +17,13 @@ import Assistant.WebApp.DashBoard import Assistant.WebApp.SideBar import Assistant.WebApp.Notifications import Assistant.WebApp.Configurators +import Assistant.WebApp.Configurators.Edit import Assistant.WebApp.Configurators.Local import Assistant.WebApp.Configurators.Ssh import Assistant.WebApp.Configurators.Pairing +#ifdef WITH_S3 import Assistant.WebApp.Configurators.S3 +#endif import Assistant.WebApp.Documentation import Assistant.WebApp.OtherRepos import Assistant.ThreadedMonad diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs index e2c3f167b..125b6d164 100644 --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -27,6 +27,7 @@ import Logs.Transfer import Types.Remote import qualified Remote import qualified Types.Remote as Remote +import Annex.Wanted import Control.Concurrent.STM import qualified Data.Map as M @@ -56,22 +57,26 @@ stubInfo f r = stubTransferInfo , associatedFile = f } -{- Adds transfers to queue for some of the known remotes. -} +{- Adds transfers to queue for some of the known remotes. + - Honors preferred content settings, only transferring wanted files. -} queueTransfers :: Schedule -> TransferQueue -> DaemonStatusHandle -> Key -> AssociatedFile -> Direction -> Annex () queueTransfers = queueTransfersMatching (const True) {- Adds transfers to queue for some of the known remotes, that match a - - condition. -} + - condition. Honors preferred content settings. -} queueTransfersMatching :: (UUID -> Bool) -> Schedule -> TransferQueue -> DaemonStatusHandle -> Key -> AssociatedFile -> Direction -> Annex () -queueTransfersMatching matching schedule q dstatus k f direction = do - rs <- sufficientremotes - =<< knownRemotes <$> liftIO (getDaemonStatus dstatus) - let matchingrs = filter (matching . Remote.uuid) rs - if null matchingrs - then defer - else forM_ matchingrs $ \r -> liftIO $ - enqueue schedule q dstatus (gentransfer r) (stubInfo f r) +queueTransfersMatching matching schedule q dstatus k f direction + | direction == Download = whenM (wantGet f) go + | otherwise = go where + go = do + rs <- sufficientremotes + =<< syncRemotes <$> liftIO (getDaemonStatus dstatus) + let matchingrs = filter (matching . Remote.uuid) rs + if null matchingrs + then defer + else forM_ matchingrs $ \r -> liftIO $ + enqueue schedule q dstatus (gentransfer r) (stubInfo f r) sufficientremotes rs {- Queue downloads from all remotes that - have the key, with the cheapest ones first. @@ -80,11 +85,9 @@ queueTransfersMatching matching schedule q dstatus k f direction = do | direction == Download = do uuids <- Remote.keyLocations k return $ filter (\r -> uuid r `elem` uuids) rs - {- TODO: Determine a smaller set of remotes that - - can be uploaded to, in order to ensure all - - remotes can access the content. Currently, - - send to every remote we can. -} - | otherwise = return $ filter (not . Remote.readonly) rs + {- Upload to all remotes that want the content. -} + | otherwise = filterM (wantSend f . Remote.uuid) $ + filter (not . Remote.readonly) rs gentransfer r = Transfer { transferDirection = direction , transferKey = k @@ -101,8 +104,8 @@ queueTransfersMatching matching schedule q dstatus k f direction = do - any others in the list to try again later. -} queueDeferredDownloads :: Schedule -> TransferQueue -> DaemonStatusHandle -> Annex () queueDeferredDownloads schedule q dstatus = do - rs <- knownRemotes <$> liftIO (getDaemonStatus dstatus) l <- liftIO $ atomically $ swapTVar (deferreddownloads q) [] + rs <- syncRemotes <$> liftIO (getDaemonStatus dstatus) left <- filterM (queue rs) l unless (null left) $ liftIO $ atomically $ modifyTVar' (deferreddownloads q) $ |