converted copy and move
Got a little tricky..
This commit is contained in:
parent
032e6485fa
commit
8ad927dbc6
8 changed files with 136 additions and 81 deletions
|
@ -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 ()
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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)
|
||||
cmd = command "copy" SectionCommon
|
||||
"copy content of files to/from another repository"
|
||||
paramPaths ((seek <=< finishParse) <$$> optParser)
|
||||
|
||||
copyOptions :: [Option]
|
||||
copyOptions = Command.Move.moveOptions ++ [autoOption]
|
||||
data CopyOptions = CopyOptions
|
||||
{ moveOptions :: Command.Move.MoveOptions
|
||||
, autoMode :: Bool
|
||||
}
|
||||
|
||||
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
|
||||
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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
cmd = command "move" SectionCommon
|
||||
"move content of files to/from another repository"
|
||||
paramPaths ((seek <=< finishParse) <$$> optParser)
|
||||
|
||||
moveOptions :: [Option]
|
||||
moveOptions = fromToOptions ++ [jobsOption] ++ keyOptions ++ annexedMatchingOptions
|
||||
data MoveOptions = MoveOptions
|
||||
{ moveFiles :: CmdParams
|
||||
, fromToOptions :: FromToOptions
|
||||
, keyOptions :: Maybe KeyOptions
|
||||
}
|
||||
|
||||
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
|
||||
-- TODO: jobsOption, annexedMatchingOptions
|
||||
|
||||
start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> Key -> CommandStart
|
||||
start to from move = start' to from move . Just
|
||||
optParser :: CmdParamsDesc -> Parser MoveOptions
|
||||
optParser desc = MoveOptions
|
||||
<$> cmdParams desc
|
||||
<*> parseFromToOptions
|
||||
<*> optional (parseKeyOptions False)
|
||||
|
||||
startKey :: Maybe Remote -> Maybe Remote -> Bool -> Key -> CommandStart
|
||||
startKey to from move = start' to from move Nothing
|
||||
instance DeferredParseClass MoveOptions where
|
||||
finishParse v = MoveOptions
|
||||
<$> pure (moveFiles v)
|
||||
<*> finishParse (fromToOptions v)
|
||||
<*> pure (keyOptions v)
|
||||
|
||||
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"
|
||||
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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue