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 Utility.Env
|
||||||
import Annex.Ssh
|
import Annex.Ssh
|
||||||
|
|
||||||
|
import qualified Command.Help
|
||||||
import qualified Command.Add
|
import qualified Command.Add
|
||||||
import qualified Command.Unannex
|
import qualified Command.Unannex
|
||||||
import qualified Command.Fsck
|
|
||||||
{-
|
|
||||||
import qualified Command.Help
|
|
||||||
import qualified Command.Drop
|
import qualified Command.Drop
|
||||||
import qualified Command.Move
|
import qualified Command.Move
|
||||||
import qualified Command.Copy
|
import qualified Command.Copy
|
||||||
import qualified Command.Get
|
import qualified Command.Get
|
||||||
|
import qualified Command.Fsck
|
||||||
import qualified Command.LookupKey
|
import qualified Command.LookupKey
|
||||||
import qualified Command.ContentLocation
|
import qualified Command.ContentLocation
|
||||||
import qualified Command.ExamineKey
|
import qualified Command.ExamineKey
|
||||||
|
@ -117,18 +116,16 @@ import qualified Command.TestRemote
|
||||||
#ifdef WITH_EKG
|
#ifdef WITH_EKG
|
||||||
import System.Remote.Monitoring
|
import System.Remote.Monitoring
|
||||||
#endif
|
#endif
|
||||||
-}
|
|
||||||
|
|
||||||
cmds :: [Command]
|
cmds :: [Command]
|
||||||
cmds =
|
cmds =
|
||||||
[ Command.Add.cmd
|
[ Command.Help.cmd
|
||||||
, Command.Fsck.cmd
|
, Command.Add.cmd
|
||||||
{-
|
|
||||||
, Command.Help.cmd
|
|
||||||
, Command.Get.cmd
|
, Command.Get.cmd
|
||||||
, Command.Drop.cmd
|
, Command.Drop.cmd
|
||||||
, Command.Move.cmd
|
, Command.Move.cmd
|
||||||
, Command.Copy.cmd
|
, Command.Copy.cmd
|
||||||
|
, Command.Fsck.cmd
|
||||||
, Command.Unlock.cmd
|
, Command.Unlock.cmd
|
||||||
, Command.Unlock.editcmd
|
, Command.Unlock.editcmd
|
||||||
, Command.Lock.cmd
|
, Command.Lock.cmd
|
||||||
|
@ -221,7 +218,6 @@ cmds =
|
||||||
, Command.FuzzTest.cmd
|
, Command.FuzzTest.cmd
|
||||||
, Command.TestRemote.cmd
|
, Command.TestRemote.cmd
|
||||||
#endif
|
#endif
|
||||||
-}
|
|
||||||
]
|
]
|
||||||
|
|
||||||
run :: [String] -> IO ()
|
run :: [String] -> IO ()
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU GPL version 3 or higher.
|
- Licensed under the GNU GPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
|
||||||
module CmdLine.GitAnnex.Options where
|
module CmdLine.GitAnnex.Options where
|
||||||
|
|
||||||
import System.Console.GetOpt
|
import System.Console.GetOpt
|
||||||
|
@ -54,6 +56,54 @@ gitAnnexOptions = commonOptions ++
|
||||||
>>= pure . (\r -> r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] })
|
>>= pure . (\r -> r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] })
|
||||||
>>= Annex.changeGitRepo
|
>>= 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.
|
-- Options for acting on keys, rather than work tree files.
|
||||||
data KeyOptions
|
data KeyOptions
|
||||||
= WantAllKeys
|
= WantAllKeys
|
||||||
|
@ -150,15 +200,6 @@ combiningOptions =
|
||||||
longopt o = Option [] [o] $ NoArg $ Limit.addToken o
|
longopt o = Option [] [o] $ NoArg $ Limit.addToken o
|
||||||
shortopt 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
|
||||||
jsonOption = Option ['j'] ["json"] (NoArg (Annex.setOutput JSONOutput))
|
jsonOption = Option ['j'] ["json"] (NoArg (Annex.setOutput JSONOutput))
|
||||||
"enable JSON output"
|
"enable JSON output"
|
||||||
|
|
|
@ -32,6 +32,7 @@ import CmdLine.Usage as ReExported
|
||||||
import CmdLine.Action as ReExported
|
import CmdLine.Action as ReExported
|
||||||
import CmdLine.Option as ReExported
|
import CmdLine.Option as ReExported
|
||||||
import CmdLine.GitAnnex.Options as ReExported
|
import CmdLine.GitAnnex.Options as ReExported
|
||||||
|
import Options.Applicative as ReExported hiding (command)
|
||||||
|
|
||||||
import qualified Options.Applicative as O
|
import qualified Options.Applicative as O
|
||||||
|
|
||||||
|
|
|
@ -15,34 +15,43 @@ import Annex.Wanted
|
||||||
import Annex.NumCopies
|
import Annex.NumCopies
|
||||||
|
|
||||||
cmd :: Command
|
cmd :: Command
|
||||||
cmd = withOptions copyOptions $
|
cmd = command "copy" SectionCommon
|
||||||
command "copy" SectionCommon
|
|
||||||
"copy content of files to/from another repository"
|
"copy content of files to/from another repository"
|
||||||
paramPaths (withParams seek)
|
paramPaths ((seek <=< finishParse) <$$> optParser)
|
||||||
|
|
||||||
copyOptions :: [Option]
|
data CopyOptions = CopyOptions
|
||||||
copyOptions = Command.Move.moveOptions ++ [autoOption]
|
{ moveOptions :: Command.Move.MoveOptions
|
||||||
|
, autoMode :: Bool
|
||||||
|
}
|
||||||
|
|
||||||
seek :: CmdParams -> CommandSeek
|
optParser :: CmdParamsDesc -> Parser CopyOptions
|
||||||
seek ps = do
|
optParser desc = CopyOptions
|
||||||
to <- getOptionField toOption Remote.byNameWithUUID
|
<$> Command.Move.optParser desc
|
||||||
from <- getOptionField fromOption Remote.byNameWithUUID
|
<*> parseAutoOption
|
||||||
auto <- getOptionFlag autoOption
|
|
||||||
withKeyOptions auto
|
instance DeferredParseClass CopyOptions where
|
||||||
(Command.Move.startKey to from False)
|
finishParse v = CopyOptions
|
||||||
(withFilesInGit $ whenAnnexed $ start auto to from)
|
<$> finishParse (moveOptions v)
|
||||||
ps
|
<*> 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.
|
{- A copy is just a move that does not delete the source file.
|
||||||
- However, auto mode avoids unnecessary copies, and avoids getting or
|
- However, auto mode avoids unnecessary copies, and avoids getting or
|
||||||
- sending non-preferred content. -}
|
- sending non-preferred content. -}
|
||||||
start :: Bool -> Maybe Remote -> Maybe Remote -> FilePath -> Key -> CommandStart
|
start :: CopyOptions -> FilePath -> Key -> CommandStart
|
||||||
start auto to from file key = stopUnless shouldCopy $
|
start o file key = stopUnless shouldCopy $
|
||||||
Command.Move.start to from False file key
|
Command.Move.start (moveOptions o) False file key
|
||||||
where
|
where
|
||||||
shouldCopy
|
shouldCopy
|
||||||
| auto = want <||> numCopiesCheck file key (<)
|
| autoMode o = want <||> numCopiesCheck file key (<)
|
||||||
| otherwise = return True
|
| otherwise = return True
|
||||||
want = case to of
|
want = case Command.Move.fromToOptions (moveOptions o) of
|
||||||
Nothing -> wantGet False (Just key) (Just file)
|
ToRemote _ ->
|
||||||
Just r -> wantSend False (Just key) (Just file) (Remote.uuid r)
|
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.Content
|
||||||
import Annex.Wanted
|
import Annex.Wanted
|
||||||
import Annex.Notification
|
import Annex.Notification
|
||||||
import Git.Types (RemoteName)
|
|
||||||
|
|
||||||
import qualified Data.Set as S
|
import qualified Data.Set as S
|
||||||
import Options.Applicative hiding (command)
|
|
||||||
|
|
||||||
cmd :: Command
|
cmd :: Command
|
||||||
cmd = command "drop" SectionCommon
|
cmd = command "drop" SectionCommon
|
||||||
|
@ -31,9 +29,9 @@ cmd = command "drop" SectionCommon
|
||||||
|
|
||||||
data DropOptions = DropOptions
|
data DropOptions = DropOptions
|
||||||
{ dropFiles :: CmdParams
|
{ dropFiles :: CmdParams
|
||||||
, dropFrom :: Maybe RemoteName
|
, dropFrom :: Maybe (DeferredParse Remote)
|
||||||
, autoMode :: Bool
|
, autoMode :: Bool
|
||||||
, keyOptions :: KeyOptions
|
, keyOptions :: Maybe KeyOptions
|
||||||
}
|
}
|
||||||
|
|
||||||
-- TODO: annexedMatchingOptions
|
-- TODO: annexedMatchingOptions
|
||||||
|
@ -41,12 +39,12 @@ data DropOptions = DropOptions
|
||||||
optParser :: CmdParamsDesc -> Parser DropOptions
|
optParser :: CmdParamsDesc -> Parser DropOptions
|
||||||
optParser desc = DropOptions
|
optParser desc = DropOptions
|
||||||
<$> cmdParams desc
|
<$> cmdParams desc
|
||||||
<*> parseDropFromOption
|
<*> optional parseDropFromOption
|
||||||
<*> parseAutoOption
|
<*> parseAutoOption
|
||||||
<*> parseKeyOptions False
|
<*> optional (parseKeyOptions False)
|
||||||
|
|
||||||
parseDropFromOption :: Parser (Maybe RemoteName)
|
parseDropFromOption :: Parser (DeferredParse Remote)
|
||||||
parseDropFromOption = optional $ strOption
|
parseDropFromOption = parseRemoteOption $ strOption
|
||||||
( long "from" <> short 'f' <> metavar paramRemote
|
( long "from" <> short 'f' <> metavar paramRemote
|
||||||
<> help "drop content from a remote"
|
<> 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' :: DropOptions -> Key -> AssociatedFile -> CommandStart
|
||||||
start' o key afile = do
|
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 ->
|
checkDropAuto (autoMode o) from afile key $ \numcopies ->
|
||||||
stopUnless (want from) $
|
stopUnless (want from) $
|
||||||
case from of
|
case from of
|
||||||
|
|
|
@ -40,7 +40,6 @@ import qualified Database.Fsck as FsckDb
|
||||||
|
|
||||||
import Data.Time.Clock.POSIX
|
import Data.Time.Clock.POSIX
|
||||||
import System.Posix.Types (EpochTime)
|
import System.Posix.Types (EpochTime)
|
||||||
import Options.Applicative hiding (command)
|
|
||||||
|
|
||||||
cmd :: Command
|
cmd :: Command
|
||||||
cmd = command "fsck" SectionMaintenance
|
cmd = command "fsck" SectionMaintenance
|
||||||
|
|
|
@ -18,36 +18,47 @@ import Annex.Transfer
|
||||||
import Logs.Presence
|
import Logs.Presence
|
||||||
|
|
||||||
cmd :: Command
|
cmd :: Command
|
||||||
cmd = withOptions moveOptions $
|
cmd = command "move" SectionCommon
|
||||||
command "move" SectionCommon
|
|
||||||
"move content of files to/from another repository"
|
"move content of files to/from another repository"
|
||||||
paramPaths (withParams seek)
|
paramPaths ((seek <=< finishParse) <$$> optParser)
|
||||||
|
|
||||||
moveOptions :: [Option]
|
data MoveOptions = MoveOptions
|
||||||
moveOptions = fromToOptions ++ [jobsOption] ++ keyOptions ++ annexedMatchingOptions
|
{ moveFiles :: CmdParams
|
||||||
|
, fromToOptions :: FromToOptions
|
||||||
|
, keyOptions :: Maybe KeyOptions
|
||||||
|
}
|
||||||
|
|
||||||
seek :: CmdParams -> CommandSeek
|
-- TODO: jobsOption, annexedMatchingOptions
|
||||||
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
|
optParser :: CmdParamsDesc -> Parser MoveOptions
|
||||||
start to from move = start' to from move . Just
|
optParser desc = MoveOptions
|
||||||
|
<$> cmdParams desc
|
||||||
|
<*> parseFromToOptions
|
||||||
|
<*> optional (parseKeyOptions False)
|
||||||
|
|
||||||
startKey :: Maybe Remote -> Maybe Remote -> Bool -> Key -> CommandStart
|
instance DeferredParseClass MoveOptions where
|
||||||
startKey to from move = start' to from move Nothing
|
finishParse v = MoveOptions
|
||||||
|
<$> pure (moveFiles v)
|
||||||
|
<*> finishParse (fromToOptions v)
|
||||||
|
<*> pure (keyOptions v)
|
||||||
|
|
||||||
start' :: Maybe Remote -> Maybe Remote -> Bool -> AssociatedFile -> Key -> CommandStart
|
seek :: MoveOptions -> CommandSeek
|
||||||
start' to from move afile key = do
|
seek o = withKeyOptions (keyOptions o) False
|
||||||
case (from, to) of
|
(startKey o True)
|
||||||
(Nothing, Nothing) -> error "specify either --from or --to"
|
(withFilesInGit $ whenAnnexed $ start o True)
|
||||||
(Nothing, Just dest) -> toStart dest move afile key
|
(moveFiles o)
|
||||||
(Just src, Nothing) -> fromStart src move afile key
|
|
||||||
_ -> error "only one of --from or --to can be specified"
|
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 :: Bool -> Key -> AssociatedFile -> Annex ()
|
||||||
showMoveAction move = showStart' (if move then "move" else "copy")
|
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
|
- A file's content can be moved even if there are insufficient copies to
|
||||||
- allow it to be dropped.
|
- allow it to be dropped.
|
||||||
-}
|
-}
|
||||||
toStart :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart
|
toStart :: Bool -> AssociatedFile -> Key -> Remote -> CommandStart
|
||||||
toStart dest move afile key = do
|
toStart move afile key dest = do
|
||||||
u <- getUUID
|
u <- getUUID
|
||||||
ishere <- inAnnex key
|
ishere <- inAnnex key
|
||||||
if not ishere || u == Remote.uuid dest
|
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
|
- If the current repository already has the content, it is still removed
|
||||||
- from the remote.
|
- from the remote.
|
||||||
-}
|
-}
|
||||||
fromStart :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart
|
fromStart :: Bool -> AssociatedFile -> Key -> Remote -> CommandStart
|
||||||
fromStart src move afile key
|
fromStart move afile key src
|
||||||
| move = go
|
| move = go
|
||||||
| otherwise = stopUnless (not <$> inAnnex key) go
|
| otherwise = stopUnless (not <$> inAnnex key) go
|
||||||
where
|
where
|
||||||
|
|
|
@ -49,8 +49,8 @@ start (k:[]) = do
|
||||||
, transferUUID = u
|
, transferUUID = u
|
||||||
, transferKey = key
|
, transferKey = key
|
||||||
}
|
}
|
||||||
info <- liftIO $ startTransferInfo file
|
tinfo <- liftIO $ startTransferInfo file
|
||||||
(update, tfile, _) <- mkProgressUpdater t info
|
(update, tfile, _) <- mkProgressUpdater t tinfo
|
||||||
liftIO $ mapM_ void
|
liftIO $ mapM_ void
|
||||||
[ tryIO $ forever $ do
|
[ tryIO $ forever $ do
|
||||||
bytes <- readUpdate
|
bytes <- readUpdate
|
||||||
|
|
Loading…
Reference in a new issue