diff options
Diffstat (limited to 'Command/Sync.hs')
| -rw-r--r-- | Command/Sync.hs | 75 |
1 files changed, 36 insertions, 39 deletions
diff --git a/Command/Sync.hs b/Command/Sync.hs index 1b5082700..9db3c7ad7 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -47,7 +47,7 @@ import Control.Concurrent.MVar def :: [Command] def = [withOptions syncOptions $ command "sync" (paramOptional (paramRepeating paramRemote)) - [seek] SectionCommon "synchronize local repository with remotes"] + seek SectionCommon "synchronize local repository with remotes"] syncOptions :: [Option] syncOptions = [ contentOption ] @@ -55,7 +55,6 @@ syncOptions = [ contentOption ] contentOption :: Option contentOption = Option.flag [] "content" "also transfer file contents" --- syncing involves several operations, any of which can independently fail seek :: CommandSeek seek rs = do prepMerge @@ -78,18 +77,18 @@ seek rs = do remotes <- syncRemotes rs let gitremotes = filter Remote.gitSyncableRemote remotes - synccontent <- ifM (Annex.getFlag $ Option.name contentOption) - ( withFilesInGit (whenAnnexed $ syncContent remotes) [] - , return [] - ) - - return $ concat + -- Syncing involves many actions, any of which can independently + -- fail, without preventing the others from running. + seekActions $ return $ concat [ [ commit ] , [ withbranch mergeLocal ] , map (withbranch . pullRemote) gitremotes - , [ mergeAnnex ] - , synccontent - , [ withbranch pushLocal ] + , [ mergeAnnex ] + ] + whenM (Annex.getFlag $ Option.name contentOption) $ + seekSyncContent remotes + seekActions $ return $ concat + [ [ withbranch pushLocal ] , map (withbranch . pushRemote) gitremotes ] @@ -499,29 +498,24 @@ newer remote b = do - Drop it from each remote that has it, where it's not preferred content - (honoring numcopies). -} -syncContent :: [Remote] -> FilePath -> (Key, Backend) -> CommandStart -syncContent rs f (k, _) = do +seekSyncContent :: [Remote] -> Annex () +seekSyncContent rs = mapM_ go =<< seekHelper LsFiles.inRepo [] + where + go f = ifAnnexed f (syncFile rs f) noop + +syncFile :: [Remote] -> FilePath -> (Key, Backend) -> Annex () +syncFile rs f (k, _) = do locs <- loggedLocations k let (have, lack) = partition (\r -> Remote.uuid r `elem` locs) rs - - getresults <- sequence =<< handleget have - (putresults, putrs) <- unzip <$> (sequence =<< handleput lack) - - let locs' = catMaybes putrs ++ locs - handleDropsFrom locs' rs "unwanted" True k (Just f) Nothing - - let results = getresults ++ putresults - if null results - then stop - else do - showStart "sync" f - next $ next $ return $ all id results - where - run a = do - r <- a - showEndResult r - return r + sequence_ =<< handleget have + putrs <- catMaybes . snd . unzip <$> (sequence =<< handleput lack) + + -- Using callCommand rather than commandAction for drops, + -- because a failure to drop does not mean the sync failed. + handleDropsFrom (putrs ++ locs) rs "unwanted" True k (Just f) + Nothing callCommand + where wantget have = allM id [ pure (not $ null have) , not <$> inAnnex k @@ -531,9 +525,9 @@ syncContent rs f (k, _) = do ( return [ get have ] , return [] ) - get have = do + get have = commandAction $ do showStart "get" f - run $ getViaTmp k $ \dest -> getKeyFile' k (Just f) dest have + next $ next $ getViaTmp k $ \dest -> getKeyFile' k (Just f) dest have wantput r | Remote.readonly r || remoteAnnexReadOnly (Types.Remote.gitconfig r) = return False @@ -543,10 +537,13 @@ syncContent rs f (k, _) = do , return [] ) put dest = do - showStart "copy" f - showAction $ "to " ++ Remote.name dest - ok <- run $ upload (Remote.uuid dest) k (Just f) noRetry $ - Remote.storeKey dest k (Just f) - when ok $ - Remote.logStatus dest k InfoPresent + ok <- commandAction $ do + showStart "copy" f + showAction $ "to " ++ Remote.name dest + next $ next $ do + ok <- upload (Remote.uuid dest) k (Just f) noRetry $ + Remote.storeKey dest k (Just f) + when ok $ + Remote.logStatus dest k InfoPresent + return ok return (ok, if ok then Just (Remote.uuid dest) else Nothing) |