mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

incomplete multiple --from / --to support

Browse source 
Note that --from foo --to bar is still not allowed by the option parser.
The goal of this change is only to support the same action over a group
of remotes, not multiple different actions. For the same reason
--to here --to foo is not allowed, since that's really two different
actions.

Each file is processed for all listed remotes in turn, so this is not
the same as two git-annex commands run in sequence. Instead, it allows
concurrent actions to several remotes.

Only move and transferkey converted so far. The code in Command.Move is
ugly and needs to be refactored and generalized.
Build fails due to unconverted modules.

This commit was sponsored by Fernando Jimenez on Patreon.
This commit is contained in:
Joey Hess 2018-10-01 15:40:12 -04:00
parent 53526136e8
commit 31ed034f69
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
6 changed files with 65 additions and 45 deletions
Download patch file Download diff file Expand all files Collapse all files

34
Command/Move.hs
View file

@ -28,7 +28,7 @@ cmd = withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption, annexedMat
data MoveOptions = MoveOptions
{ moveFiles :: CmdParams
, fromToOptions :: FromToHereOptions
, fromToOptions :: FromToHereOptions [DeferredParse Remote]
, removeWhen :: RemoveWhen
, keyOptions :: Maybe KeyOptions
, batchOption :: BatchMode
@ -54,34 +54,42 @@ data RemoveWhen = RemoveSafe | RemoveNever
deriving (Show, Eq)
seek :: MoveOptions -> CommandSeek
seek o = allowConcurrentOutput $ do
let go = whenAnnexed $ start (fromToOptions o) (removeWhen o)
seek o = allowConcurrentOutput $
case batchOption o of
Batch fmt -> batchFilesMatching fmt go
Batch fmt -> batchFilesMatching fmt $ \f -> seekremotes' $ \r -> go r f
NoBatch -> withKeyOptions (keyOptions o) False
(commandAction . startKey (fromToOptions o) (removeWhen o))
(withFilesInGit (commandAction . go))
(\kai -> seekremotes $ \r -> commandAction $ startKey r (removeWhen o) kai)
(withFilesInGit $ \f -> seekremotes $ \r -> commandAction $ go r f)
=<< workTreeItems (moveFiles o)
where
go r = whenAnnexed $ start r (removeWhen o)
start :: FromToHereOptions -> RemoveWhen -> FilePath -> Key -> CommandStart
seekremotes :: (FromToHereOptions Remote -> Annex ()) -> Annex ()
seekremotes a = case fromToOptions o of
Right (From rs) -> mapM_ (a . Right . From) =<< mapM getParsed rs
Right (To rs) -> mapM_ (a . Right . To) =<< mapM getParsed rs
Left ToHere -> a $ Left ToHere
seekremotes' = undefined
start :: FromToHereOptions Remote -> RemoveWhen -> FilePath -> Key -> CommandStart
start fromto removewhen f k =
start' fromto removewhen afile k (mkActionItem afile)
where
afile = AssociatedFile (Just f)
startKey :: FromToHereOptions -> RemoveWhen -> (Key, ActionItem) -> CommandStart
startKey :: FromToHereOptions Remote -> RemoveWhen -> (Key, ActionItem) -> CommandStart
startKey fromto removewhen =
uncurry $ start' fromto removewhen (AssociatedFile Nothing)
start' :: FromToHereOptions -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart
start' :: FromToHereOptions Remote -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart
start' fromto removewhen afile key ai = onlyActionOn key $
case fromto of
Right (FromRemote src) ->
Right (From src) ->
checkFailedTransferDirection ai Download $
fromStart removewhen afile key ai =<< getParsed src
Right (ToRemote dest) ->
fromStart removewhen afile key ai src
Right (To dest) ->
checkFailedTransferDirection ai Upload $
toStart removewhen afile key ai =<< getParsed dest
toStart removewhen afile key ai dest
Left ToHere ->
checkFailedTransferDirection ai Download $
toHereStart removewhen afile key ai

27
Command/TransferKey.hs
View file

@ -22,7 +22,7 @@ cmd = noCommit $
data TransferKeyOptions = TransferKeyOptions
{ keyOptions :: CmdParams
, fromToOptions :: FromToOptions
, fromToOptions :: FromToOptions [DeferredParse Remote]
, fileOption :: AssociatedFile
}
@ -42,26 +42,27 @@ instance DeferredParseClass TransferKeyOptions where
<*> pure (fileOption v)
seek :: TransferKeyOptions -> CommandSeek
seek o = withKeys (commandAction . start o) (keyOptions o)
seek o = withKeys go (keyOptions o)
where
go k = case fromToOptions o of
To dest -> commandActions =<<
(map (toStart k (fileOption o)) <$> mapM getParsed dest)
From src -> commandActions =<<
(map (fromStart k (fileOption o)) <$> mapM getParsed src)
start :: TransferKeyOptions -> Key -> CommandStart
start o key = case fromToOptions o of
ToRemote dest -> next $ toPerform key (fileOption o) =<< getParsed dest
FromRemote src -> next $ fromPerform key (fileOption o) =<< getParsed src
toPerform :: Key -> AssociatedFile -> Remote -> CommandPerform
toPerform key file remote = go Upload file $
toStart :: Key -> AssociatedFile -> Remote -> CommandStart
toStart key file remote = next $ perform Upload file $
upload (uuid remote) key file stdRetry $ \p -> do
ok <- Remote.storeKey remote key file p
when ok $
Remote.logStatus remote key InfoPresent
return ok
fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform
fromPerform key file remote = go Upload file $
fromStart :: Key -> AssociatedFile -> Remote -> CommandStart
fromStart key file remote = next $ perform Upload file $
download (uuid remote) key file stdRetry $ \p ->
getViaTmp (retrievalSecurityPolicy remote) (RemoteVerify remote) key $
\t -> Remote.retrieveKeyFile remote key file t p
go :: Direction -> AssociatedFile -> (NotifyWitness -> Annex Bool) -> CommandPerform
go direction file a = notifyTransfer direction file a >>= liftIO . exitBool
perform :: Direction -> AssociatedFile -> (NotifyWitness -> Annex Bool) -> CommandPerform
perform direction file a = notifyTransfer direction file a >>= liftIO . exitBool