move/copy: option parsing for --from with --to
Allowing --from and --to as an alternative to --from or --to is hard to do with optparse-applicative! The obvious approach of (pfrom <|> pto <|> pfromandto) does not work when pfromandto uses the same option names as pfrom and pto do. It compiles but the generated parser does not work for all desired combinations. Instead, have to parse optionally from and optionally to. When neither is provided, the parser succeeds, but it's a result that can't be handled. So, have to giveup after option parsing. There does not seem to be a way to make an optparse-applicative Parser give up internally either. Also, need seek' because I first tried making fto be a where binding, but that resulted in a hang when git-annex move was run without --from or --to. I think because startConcurrency was not expecting the stages value to contain an exception and so ended up blocking. Sponsored-by: Dartmouth College's DANDI project
This commit is contained in:
parent
2a92f5cc2c
commit
a6c1d9752b
6 changed files with 93 additions and 49 deletions
|
@ -1,6 +1,6 @@
|
|||
{- git-annex command
|
||||
-
|
||||
- Copyright 2010 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2010-2023 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
@ -21,7 +21,7 @@ cmd = withAnnexOptions [jobsOption, jsonOptions, jsonProgressOption, annexedMatc
|
|||
|
||||
data CopyOptions = CopyOptions
|
||||
{ copyFiles :: CmdParams
|
||||
, fromToOptions :: FromToHereOptions
|
||||
, fromToOptions :: Maybe FromToHereOptions
|
||||
, keyOptions :: Maybe KeyOptions
|
||||
, autoMode :: Bool
|
||||
, batchOption :: BatchMode
|
||||
|
@ -38,13 +38,19 @@ optParser desc = CopyOptions
|
|||
instance DeferredParseClass CopyOptions where
|
||||
finishParse v = CopyOptions
|
||||
<$> pure (copyFiles v)
|
||||
<*> finishParse (fromToOptions v)
|
||||
<*> maybe (pure Nothing) (Just <$$> finishParse)
|
||||
(fromToOptions v)
|
||||
<*> pure (keyOptions v)
|
||||
<*> pure (autoMode v)
|
||||
<*> pure (batchOption v)
|
||||
|
||||
seek :: CopyOptions -> CommandSeek
|
||||
seek o = startConcurrency commandStages $ do
|
||||
seek o = case fromToOptions o of
|
||||
Just fto -> seek' o fto
|
||||
Nothing -> giveup "Specify --from or --to"
|
||||
|
||||
seek' :: CopyOptions -> FromToHereOptions -> CommandSeek
|
||||
seek' o fto = startConcurrency commandStages $ do
|
||||
case batchOption o of
|
||||
NoBatch -> withKeyOptions
|
||||
(keyOptions o) (autoMode o) seeker
|
||||
|
@ -57,30 +63,33 @@ seek o = startConcurrency commandStages $ do
|
|||
ww = WarnUnmatchLsFiles
|
||||
|
||||
seeker = AnnexedFileSeeker
|
||||
{ startAction = start o
|
||||
, checkContentPresent = case fromToOptions o of
|
||||
Right (FromRemote _) -> Just False
|
||||
Right (ToRemote _) -> Just True
|
||||
Left ToHere -> Just False
|
||||
{ startAction = start o fto
|
||||
, checkContentPresent = case fto of
|
||||
FromOrToRemote (FromRemote _) -> Just False
|
||||
FromOrToRemote (ToRemote _) -> Just True
|
||||
ToHere -> Just False
|
||||
FromRemoteToRemote _ _ -> Just False
|
||||
, usesLocationLog = True
|
||||
}
|
||||
keyaction = Command.Move.startKey (fromToOptions o) Command.Move.RemoveNever
|
||||
keyaction = Command.Move.startKey fto Command.Move.RemoveNever
|
||||
|
||||
{- A copy is just a move that does not delete the source file.
|
||||
- However, auto mode avoids unnecessary copies, and avoids getting or
|
||||
- sending non-preferred content. -}
|
||||
start :: CopyOptions -> SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start o si file key = stopUnless shouldCopy $
|
||||
Command.Move.start (fromToOptions o) Command.Move.RemoveNever si file key
|
||||
start :: CopyOptions -> FromToHereOptions -> SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start o fto si file key = stopUnless shouldCopy $
|
||||
Command.Move.start fto Command.Move.RemoveNever si file key
|
||||
where
|
||||
shouldCopy
|
||||
| autoMode o = want <||> numCopiesCheck file key (<)
|
||||
| otherwise = return True
|
||||
want = case fromToOptions o of
|
||||
Right (ToRemote dest) ->
|
||||
want = case fto of
|
||||
FromOrToRemote (ToRemote dest) ->
|
||||
(Remote.uuid <$> getParsed dest) >>= checkwantsend
|
||||
FromOrToRemote (FromRemote _) -> checkwantget
|
||||
ToHere -> checkwantget
|
||||
FromRemoteToRemote _ dest ->
|
||||
(Remote.uuid <$> getParsed dest) >>= checkwantsend
|
||||
Right (FromRemote _) -> checkwantget
|
||||
Left ToHere -> checkwantget
|
||||
|
||||
checkwantsend = wantGetBy False (Just key) (AssociatedFile (Just file))
|
||||
checkwantget = wantGet False (Just key) (AssociatedFile (Just file))
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue