diff options
Diffstat (limited to 'Command/Move.hs')
| -rw-r--r-- | Command/Move.hs | 78 |
1 files changed, 45 insertions, 33 deletions
diff --git a/Command/Move.hs b/Command/Move.hs index 6867052de..d95bce6ab 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -17,35 +17,47 @@ import Annex.UUID import Annex.Transfer import Logs.Presence -cmd :: [Command] -cmd = [withOptions moveOptions $ command "move" paramPaths seek - SectionCommon "move content of files to/from another repository"] - -moveOptions :: [Option] -moveOptions = fromToOptions ++ [jobsOption] ++ keyOptions ++ annexedMatchingOptions - -seek :: CommandSeek -seek ps = do - to <- getOptionField toOption Remote.byNameWithUUID - from <- getOptionField fromOption Remote.byNameWithUUID - withKeyOptions False - (startKey to from True) - (withFilesInGit $ whenAnnexed $ start to from True) - ps - -start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> Key -> CommandStart -start to from move = start' to from move . Just - -startKey :: Maybe Remote -> Maybe Remote -> Bool -> Key -> CommandStart -startKey to from move = start' to from move Nothing - -start' :: Maybe Remote -> Maybe Remote -> Bool -> AssociatedFile -> Key -> CommandStart -start' to from move afile key = do - case (from, to) of - (Nothing, Nothing) -> error "specify either --from or --to" - (Nothing, Just dest) -> toStart dest move afile key - (Just src, Nothing) -> fromStart src move afile key - _ -> error "only one of --from or --to can be specified" +cmd :: Command +cmd = withGlobalOptions (jobsOption : annexedMatchingOptions) $ + command "move" SectionCommon + "move content of files to/from another repository" + paramPaths (seek <--< optParser) + +data MoveOptions = MoveOptions + { moveFiles :: CmdParams + , fromToOptions :: FromToOptions + , keyOptions :: Maybe KeyOptions + } + +optParser :: CmdParamsDesc -> Parser MoveOptions +optParser desc = MoveOptions + <$> cmdParams desc + <*> parseFromToOptions + <*> optional (parseKeyOptions False) + +instance DeferredParseClass MoveOptions where + finishParse v = MoveOptions + <$> pure (moveFiles v) + <*> finishParse (fromToOptions v) + <*> pure (keyOptions v) + +seek :: MoveOptions -> CommandSeek +seek o = withKeyOptions (keyOptions o) False + (startKey o True) + (withFilesInGit $ whenAnnexed $ start o True) + (moveFiles o) + +start :: MoveOptions -> Bool -> FilePath -> Key -> CommandStart +start o move = start' o move . Just + +startKey :: MoveOptions -> Bool -> Key -> CommandStart +startKey o move = start' o move Nothing + +start' :: MoveOptions -> Bool -> AssociatedFile -> Key -> CommandStart +start' o move afile key = + case fromToOptions o of + FromRemote src -> fromStart move afile key =<< getParsed src + ToRemote dest -> toStart move afile key =<< getParsed dest showMoveAction :: Bool -> Key -> AssociatedFile -> Annex () showMoveAction move = showStart' (if move then "move" else "copy") @@ -59,8 +71,8 @@ showMoveAction move = showStart' (if move then "move" else "copy") - A file's content can be moved even if there are insufficient copies to - allow it to be dropped. -} -toStart :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart -toStart dest move afile key = do +toStart :: Bool -> AssociatedFile -> Key -> Remote -> CommandStart +toStart move afile key dest = do u <- getUUID ishere <- inAnnex key if not ishere || u == Remote.uuid dest @@ -122,8 +134,8 @@ toPerform dest move key afile fastcheck isthere = - If the current repository already has the content, it is still removed - from the remote. -} -fromStart :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart -fromStart src move afile key +fromStart :: Bool -> AssociatedFile -> Key -> Remote -> CommandStart +fromStart move afile key src | move = go | otherwise = stopUnless (not <$> inAnnex key) go where |