much better command action handling for sync --content

This commit is contained in:
Joey Hess 2014-01-20 13:31:03 -04:00
parent cfa6865056
commit 73c420ffcf
5 changed files with 68 additions and 61 deletions

View file

@ -18,6 +18,7 @@ import Annex.Wanted
import Annex.Exception
import Config
import Annex.Content.Direct
import RunCommand
import qualified Data.Set as S
import System.Log.Logger (debugM)
@ -27,29 +28,24 @@ type Reason = String
{- Drop a key from local and/or remote when allowed by the preferred content
- and numcopies settings.
-
- The Remote list can include other remotes that do not have the content.
-
- A remote can be specified that is known to have the key. This can be
- used an an optimisation when eg, a key has just been uploaded to a
- remote.
-}
handleDrops :: Reason -> [Remote] -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Annex ()
handleDrops _ _ _ _ Nothing _ = noop
handleDrops reason rs fromhere key f knownpresentremote = do
locs <- loggedLocations key
handleDropsFrom locs rs reason fromhere key f knownpresentremote
{- The UUIDs are ones where the content is believed to be present.
- The UUIDs are ones where the content is believed to be present.
- The Remote list can include other remotes that do not have the content;
- only ones that match the UUIDs will be dropped from.
- If allowed to drop fromhere, that drop will be tried first.
-
- A remote can be specified that is known to have the key. This can be
- used an an optimisation when eg, a key has just been uploaded to a
- remote.
-
- In direct mode, all associated files are checked, and only if all
- of them are unwanted are they dropped.
-
- The runner is used to run commands, and so can be either callCommand
- or commandAction.
-}
handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Annex ()
handleDropsFrom _ _ _ _ _ Nothing _ = noop
handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote = do
handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> CommandActionRunner -> Annex ()
handleDropsFrom _ _ _ _ _ Nothing _ _ = noop
handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote runner = do
fs <- ifM isDirect
( do
l <- associatedFilesRelative key
@ -92,7 +88,7 @@ handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote = do
checkdrop fs n@(have, numcopies, _untrusted) u a =
ifM (allM (wantDrop True u . Just) fs)
( ifM (safely $ callCommand $ a (Just numcopies))
( ifM (safely $ runner $ a (Just numcopies))
( do
liftIO $ debugM "drop" $ unwords
[ "dropped"
@ -113,6 +109,7 @@ handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote = do
dropr fs r n = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies ->
Command.Drop.startRemote (Just afile) numcopies key r
slocs = S.fromList locs
safely a = either (const False) id <$> tryAnnex a
slocs = S.fromList locs

View file

@ -14,6 +14,7 @@ import Assistant.Common
import Assistant.DaemonStatus
import Annex.Drop (handleDropsFrom, Reason)
import Logs.Location
import RunCommand
{- Drop from local and/or remote when allowed by the preferred content and
- numcopies settings. -}
@ -22,4 +23,4 @@ handleDrops _ _ _ Nothing _ = noop
handleDrops reason fromhere key f knownpresentremote = do
syncrs <- syncDataRemotes <$> getDaemonStatus
locs <- liftAnnex $ loggedLocations key
liftAnnex $ handleDropsFrom locs syncrs reason fromhere key f knownpresentremote
liftAnnex $ handleDropsFrom locs syncrs reason fromhere key f knownpresentremote callCommand

View file

@ -29,6 +29,7 @@ import qualified Git.LsFiles as LsFiles
import qualified Backend
import Annex.Content
import Annex.Wanted
import RunCommand
import qualified Data.Set as S
@ -158,7 +159,7 @@ expensiveScan urlrenderer rs = unless onlyweb $ batch <~> do
present <- liftAnnex $ inAnnex key
liftAnnex $ handleDropsFrom locs syncrs
"expensive scan found too many copies of object"
present key (Just f) Nothing
present key (Just f) Nothing callCommand
liftAnnex $ do
let slocs = S.fromList locs
let use a = return $ mapMaybe (a key slocs) syncrs

View file

@ -79,14 +79,18 @@ seek rs = do
-- Syncing involves many actions, any of which can independently
-- fail, without preventing the others from running.
seekActions $ return [ commit ]
seekActions $ return [ withbranch mergeLocal ]
seekActions $ return $ map (withbranch . pullRemote) gitremotes
seekActions $ return [ mergeAnnex ]
seekActions $ return $ concat
[ [ commit ]
, [ withbranch mergeLocal ]
, map (withbranch . pullRemote) gitremotes
, [ mergeAnnex ]
]
whenM (Annex.getFlag $ Option.name contentOption) $
withFilesInGit (whenAnnexed $ syncContent remotes) []
seekActions $ return $ [ withbranch pushLocal ]
seekActions $ return $ map (withbranch . pushRemote) gitremotes
seekSyncContent remotes
seekActions $ return $ concat
[ [ withbranch pushLocal ]
, map (withbranch . pushRemote) gitremotes
]
{- Merging may delete the current directory, so go to the top
- of the repo. This also means that sync always acts on all files in the
@ -494,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)
sequence_ =<< handleget have
putrs <- catMaybes . snd . 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
-- 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
run a = do
r <- a
showEndResult r
return r
wantget have = allM id
[ pure (not $ null have)
, not <$> inAnnex k
@ -526,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
@ -538,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)

View file

@ -15,6 +15,8 @@ import Types.Command
import qualified Annex.Queue
import Annex.Exception
type CommandActionRunner = CommandStart -> CommandCleanup
{- Runs a command, starting with the check stage, and then
- the seek stage. Finishes by printing the number of commandActions that
- failed. -}
@ -34,25 +36,29 @@ performCommand Command { cmdseek = seek, cmdcheck = c, cmdname = name } params =
- command).
-
- This should only be run in the seek stage. -}
commandAction :: CommandStart -> Annex ()
commandAction :: CommandActionRunner
commandAction a = handle =<< tryAnnexIO go
where
go = do
Annex.Queue.flushWhenFull
callCommand a
handle (Right True) = noop
handle (Right True) = return True
handle (Right False) = incerr
handle (Left err) = do
showErr err
showEndFail
incerr
incerr = Annex.changeState $ \s ->
let ! c = Annex.errcounter s + 1
! s' = s { Annex.errcounter = c }
in s'
incerr = do
Annex.changeState $ \s ->
let ! c = Annex.errcounter s + 1
! s' = s { Annex.errcounter = c }
in s'
return False
{- Runs a single command action through the start, perform and cleanup stages -}
callCommand :: CommandStart -> CommandCleanup
{- Runs a single command action through the start, perform and cleanup
- stages, without catching errors. Useful if one command wants to run
- part of another command. -}
callCommand :: CommandActionRunner
callCommand = start
where
start = stage $ maybe skip perform