diff options
Diffstat (limited to 'Command/Drop.hs')
-rw-r--r-- | Command/Drop.hs | 102 |
1 files changed, 60 insertions, 42 deletions
diff --git a/Command/Drop.hs b/Command/Drop.hs index a93dac595..b569491bb 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -19,50 +19,68 @@ import Annex.NumCopies import Annex.Content import Annex.Wanted import Annex.Notification +import Git.Types (RemoteName) import qualified Data.Set as S +import Options.Applicative hiding (command) cmd :: Command -cmd = withOptions (dropOptions) $ - command "drop" SectionCommon - "indicate content of files not currently wanted" - paramPaths (withParams seek) - -dropOptions :: [Option] -dropOptions = dropFromOption : annexedMatchingOptions ++ [autoOption] ++ keyOptions - -dropFromOption :: Option -dropFromOption = fieldOption ['f'] "from" paramRemote "drop content from a remote" - -seek :: CmdParams -> CommandSeek -seek ps = do - from <- getOptionField dropFromOption Remote.byNameWithUUID - auto <- getOptionFlag autoOption - withKeyOptions auto - (startKeys auto from) - (withFilesInGit $ whenAnnexed $ start auto from) - ps - -start :: Bool -> Maybe Remote -> FilePath -> Key -> CommandStart -start auto from file key = start' auto from key (Just file) - -start' :: Bool -> Maybe Remote -> Key -> AssociatedFile -> CommandStart -start' auto from key afile = checkDropAuto auto from afile key $ \numcopies -> - stopUnless want $ - case from of - Nothing -> startLocal afile numcopies key Nothing - Just remote -> do - u <- getUUID - if Remote.uuid remote == u - then startLocal afile numcopies key Nothing - else startRemote afile numcopies key remote - where - want - | auto = wantDrop False (Remote.uuid <$> from) (Just key) afile - | otherwise = return True - -startKeys :: Bool -> Maybe Remote -> Key -> CommandStart -startKeys auto from key = start' auto from key Nothing +cmd = command "drop" SectionCommon + "indicate content of files not currently wanted" + paramPaths (seek <$$> optParser) + +data DropOptions = DropOptions + { dropFiles :: CmdParams + , dropFrom :: Maybe RemoteName + , autoMode :: Bool + , keyOptions :: KeyOptions + } + +-- TODO: annexedMatchingOptions + +optParser :: CmdParamsDesc -> Parser DropOptions +optParser desc = DropOptions + <$> cmdParams desc + <*> parseDropFromOption + <*> parseAutoOption + <*> parseKeyOptions False + +parseDropFromOption :: Parser (Maybe RemoteName) +parseDropFromOption = finalOpt $ strOption + ( long "from" + <> short 'f' + <> metavar paramRemote + <> help "drop content from a remote" + ) + +seek :: DropOptions -> CommandSeek +seek o = withKeyOptions (keyOptions o) (autoMode o) + (startKeys o) + (withFilesInGit $ whenAnnexed $ start o) + (dropFiles o) + +start :: DropOptions -> FilePath -> Key -> CommandStart +start o file key = start' o key (Just file) + +start' :: DropOptions -> Key -> AssociatedFile -> CommandStart +start' o key afile = do + from <- Remote.byNameWithUUID (dropFrom o) + checkDropAuto (autoMode o) from afile key $ \numcopies -> + stopUnless (want from) $ + case from of + Nothing -> startLocal afile numcopies key Nothing + Just remote -> do + u <- getUUID + if Remote.uuid remote == u + then startLocal afile numcopies key Nothing + else startRemote afile numcopies key remote + where + want from + | autoMode o = wantDrop False (Remote.uuid <$> from) (Just key) afile + | otherwise = return True + +startKeys :: DropOptions -> Key -> CommandStart +startKeys o key = start' o key Nothing startLocal :: AssociatedFile -> NumCopies -> Key -> Maybe Remote -> CommandStart startLocal afile numcopies key knownpresentremote = stopUnless (inAnnex key) $ do @@ -166,10 +184,10 @@ requiredContent = do {- In auto mode, only runs the action if there are enough - copies on other semitrusted repositories. -} checkDropAuto :: Bool -> Maybe Remote -> AssociatedFile -> Key -> (NumCopies -> CommandStart) -> CommandStart -checkDropAuto auto mremote afile key a = go =<< maybe getNumCopies getFileNumCopies afile +checkDropAuto automode mremote afile key a = go =<< maybe getNumCopies getFileNumCopies afile where go numcopies - | auto = do + | automode = do locs <- Remote.keyLocations key uuid <- getUUID let remoteuuid = fromMaybe uuid $ Remote.uuid <$> mremote |