diff options
| -rw-r--r-- | CmdLine/GitAnnex.hs | 14 | ||||
| -rw-r--r-- | CmdLine/GitAnnex/Options.hs | 59 | ||||
| -rw-r--r-- | Command.hs | 1 | ||||
| -rw-r--r-- | Command/Copy.hs | 57 | ||||
| -rw-r--r-- | Command/Drop.hs | 16 | ||||
| -rw-r--r-- | Command/Fsck.hs | 1 | ||||
| -rw-r--r-- | Command/Move.hs | 79 | ||||
| -rw-r--r-- | Command/TransferInfo.hs | 4 |
8 files changed, 143 insertions, 88 deletions
diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 5e37a885a..fc323a49b 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -15,15 +15,14 @@ import Command import Utility.Env import Annex.Ssh +import qualified Command.Help import qualified Command.Add import qualified Command.Unannex -import qualified Command.Fsck -{- -import qualified Command.Help import qualified Command.Drop import qualified Command.Move import qualified Command.Copy import qualified Command.Get +import qualified Command.Fsck import qualified Command.LookupKey import qualified Command.ContentLocation import qualified Command.ExamineKey @@ -117,18 +116,16 @@ import qualified Command.TestRemote #ifdef WITH_EKG import System.Remote.Monitoring #endif --} cmds :: [Command] cmds = - [ Command.Add.cmd - , Command.Fsck.cmd -{- - , Command.Help.cmd + [ Command.Help.cmd + , Command.Add.cmd , Command.Get.cmd , Command.Drop.cmd , Command.Move.cmd , Command.Copy.cmd + , Command.Fsck.cmd , Command.Unlock.cmd , Command.Unlock.editcmd , Command.Lock.cmd @@ -221,7 +218,6 @@ cmds = , Command.FuzzTest.cmd , Command.TestRemote.cmd #endif --} ] run :: [String] -> IO () diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index 02cbcdcfe..fb1b81acf 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE FlexibleInstances #-} + module CmdLine.GitAnnex.Options where import System.Console.GetOpt @@ -54,6 +56,54 @@ gitAnnexOptions = commonOptions ++ >>= pure . (\r -> r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] }) >>= Annex.changeGitRepo +-- Some values cannot be fully parsed without performing an action. +-- The action may be expensive, so it's best to call finishParse on such a +-- value before using getParsed repeatedly. +data DeferredParse a = DeferredParse (Annex a) | ReadyParse a + +class DeferredParseClass a where + finishParse :: a -> Annex a + +getParsed :: DeferredParse a -> Annex a +getParsed (DeferredParse a) = a +getParsed (ReadyParse a) = pure a + +instance DeferredParseClass (DeferredParse a) where + finishParse (DeferredParse a) = ReadyParse <$> a + finishParse (ReadyParse a) = pure (ReadyParse a) + +instance DeferredParseClass (Maybe (DeferredParse a)) where + finishParse Nothing = pure Nothing + finishParse (Just v) = Just <$> finishParse v + +parseRemoteOption :: Parser RemoteName -> Parser (DeferredParse Remote) +parseRemoteOption p = DeferredParse . (fromJust <$$> Remote.byNameWithUUID) . Just <$> p + +data FromToOptions + = FromRemote (DeferredParse Remote) + | ToRemote (DeferredParse Remote) + +instance DeferredParseClass FromToOptions where + finishParse (FromRemote v) = FromRemote <$> finishParse v + finishParse (ToRemote v) = ToRemote <$> finishParse v + +parseFromToOptions :: Parser FromToOptions +parseFromToOptions = + (FromRemote <$> parseFromOption) + <|> (ToRemote <$> parseToOption) + +parseFromOption :: Parser (DeferredParse Remote) +parseFromOption = parseRemoteOption $ strOption + ( long "from" <> short 'f' <> metavar paramRemote + <> help "source remote" + ) + +parseToOption :: Parser (DeferredParse Remote) +parseToOption = parseRemoteOption $ strOption + ( long "to" <> short 't' <> metavar paramRemote + <> help "destination remote" + ) + -- Options for acting on keys, rather than work tree files. data KeyOptions = WantAllKeys @@ -150,15 +200,6 @@ combiningOptions = longopt o = Option [] [o] $ NoArg $ Limit.addToken o shortopt o = Option o [] $ NoArg $ Limit.addToken o -fromOption :: Option -fromOption = fieldOption ['f'] "from" paramRemote "source remote" - -toOption :: Option -toOption = fieldOption ['t'] "to" paramRemote "destination remote" - -fromToOptions :: [Option] -fromToOptions = [fromOption, toOption] - jsonOption :: Option jsonOption = Option ['j'] ["json"] (NoArg (Annex.setOutput JSONOutput)) "enable JSON output" diff --git a/Command.hs b/Command.hs index b272bba5d..e3508d68c 100644 --- a/Command.hs +++ b/Command.hs @@ -32,6 +32,7 @@ import CmdLine.Usage as ReExported import CmdLine.Action as ReExported import CmdLine.Option as ReExported import CmdLine.GitAnnex.Options as ReExported +import Options.Applicative as ReExported hiding (command) import qualified Options.Applicative as O diff --git a/Command/Copy.hs b/Command/Copy.hs index 26ff8e263..a4f157e2f 100644 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -15,34 +15,43 @@ import Annex.Wanted import Annex.NumCopies cmd :: Command -cmd = withOptions copyOptions $ - command "copy" SectionCommon - "copy content of files to/from another repository" - paramPaths (withParams seek) - -copyOptions :: [Option] -copyOptions = Command.Move.moveOptions ++ [autoOption] - -seek :: CmdParams -> CommandSeek -seek ps = do - to <- getOptionField toOption Remote.byNameWithUUID - from <- getOptionField fromOption Remote.byNameWithUUID - auto <- getOptionFlag autoOption - withKeyOptions auto - (Command.Move.startKey to from False) - (withFilesInGit $ whenAnnexed $ start auto to from) - ps +cmd = command "copy" SectionCommon + "copy content of files to/from another repository" + paramPaths ((seek <=< finishParse) <$$> optParser) + +data CopyOptions = CopyOptions + { moveOptions :: Command.Move.MoveOptions + , autoMode :: Bool + } + +optParser :: CmdParamsDesc -> Parser CopyOptions +optParser desc = CopyOptions + <$> Command.Move.optParser desc + <*> parseAutoOption + +instance DeferredParseClass CopyOptions where + finishParse v = CopyOptions + <$> finishParse (moveOptions v) + <*> pure (autoMode v) + +seek :: CopyOptions -> CommandSeek +seek o = withKeyOptions (Command.Move.keyOptions $ moveOptions o) (autoMode o) + (Command.Move.startKey (moveOptions o) False) + (withFilesInGit $ whenAnnexed $ start o) + (Command.Move.moveFiles $ moveOptions o) {- 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 :: Bool -> Maybe Remote -> Maybe Remote -> FilePath -> Key -> CommandStart -start auto to from file key = stopUnless shouldCopy $ - Command.Move.start to from False file key +start :: CopyOptions -> FilePath -> Key -> CommandStart +start o file key = stopUnless shouldCopy $ + Command.Move.start (moveOptions o) False file key where shouldCopy - | auto = want <||> numCopiesCheck file key (<) + | autoMode o = want <||> numCopiesCheck file key (<) | otherwise = return True - want = case to of - Nothing -> wantGet False (Just key) (Just file) - Just r -> wantSend False (Just key) (Just file) (Remote.uuid r) + want = case Command.Move.fromToOptions (moveOptions o) of + ToRemote _ -> + wantGet False (Just key) (Just file) + FromRemote dest -> (Remote.uuid <$> getParsed dest) >>= + wantSend False (Just key) (Just file) diff --git a/Command/Drop.hs b/Command/Drop.hs index 3f4ea1a9d..1c595b6c2 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -19,10 +19,8 @@ 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 = command "drop" SectionCommon @@ -31,9 +29,9 @@ cmd = command "drop" SectionCommon data DropOptions = DropOptions { dropFiles :: CmdParams - , dropFrom :: Maybe RemoteName + , dropFrom :: Maybe (DeferredParse Remote) , autoMode :: Bool - , keyOptions :: KeyOptions + , keyOptions :: Maybe KeyOptions } -- TODO: annexedMatchingOptions @@ -41,12 +39,12 @@ data DropOptions = DropOptions optParser :: CmdParamsDesc -> Parser DropOptions optParser desc = DropOptions <$> cmdParams desc - <*> parseDropFromOption + <*> optional parseDropFromOption <*> parseAutoOption - <*> parseKeyOptions False + <*> optional (parseKeyOptions False) -parseDropFromOption :: Parser (Maybe RemoteName) -parseDropFromOption = optional $ strOption +parseDropFromOption :: Parser (DeferredParse Remote) +parseDropFromOption = parseRemoteOption $ strOption ( long "from" <> short 'f' <> metavar paramRemote <> help "drop content from a remote" ) @@ -62,7 +60,7 @@ start o file key = start' o key (Just file) start' :: DropOptions -> Key -> AssociatedFile -> CommandStart start' o key afile = do - from <- Remote.byNameWithUUID (dropFrom o) + from <- maybe (pure Nothing) (Just <$$> getParsed) (dropFrom o) checkDropAuto (autoMode o) from afile key $ \numcopies -> stopUnless (want from) $ case from of diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 09a3a82c9..dbeeefbcd 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -40,7 +40,6 @@ import qualified Database.Fsck as FsckDb import Data.Time.Clock.POSIX import System.Posix.Types (EpochTime) -import Options.Applicative hiding (command) cmd :: Command cmd = command "fsck" SectionMaintenance diff --git a/Command/Move.hs b/Command/Move.hs index fc13ca254..153114f8b 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -18,36 +18,47 @@ import Annex.Transfer import Logs.Presence cmd :: Command -cmd = withOptions moveOptions $ - command "move" SectionCommon - "move content of files to/from another repository" - paramPaths (withParams seek) - -moveOptions :: [Option] -moveOptions = fromToOptions ++ [jobsOption] ++ keyOptions ++ annexedMatchingOptions - -seek :: CmdParams -> 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 "move" SectionCommon + "move content of files to/from another repository" + paramPaths ((seek <=< finishParse) <$$> optParser) + +data MoveOptions = MoveOptions + { moveFiles :: CmdParams + , fromToOptions :: FromToOptions + , keyOptions :: Maybe KeyOptions + } + +-- TODO: jobsOption, annexedMatchingOptions + +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") @@ -61,8 +72,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 @@ -124,8 +135,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 diff --git a/Command/TransferInfo.hs b/Command/TransferInfo.hs index d102be55e..2b5713d77 100644 --- a/Command/TransferInfo.hs +++ b/Command/TransferInfo.hs @@ -49,8 +49,8 @@ start (k:[]) = do , transferUUID = u , transferKey = key } - info <- liftIO $ startTransferInfo file - (update, tfile, _) <- mkProgressUpdater t info + tinfo <- liftIO $ startTransferInfo file + (update, tfile, _) <- mkProgressUpdater t tinfo liftIO $ mapM_ void [ tryIO $ forever $ do bytes <- readUpdate |