162 lines
5 KiB
Haskell
162 lines
5 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2010-2013 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Command.Move where
|
|
|
|
import Common.Annex
|
|
import Command
|
|
import qualified Command.Drop
|
|
import qualified Annex
|
|
import Annex.Content
|
|
import qualified Remote
|
|
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 ++ 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"
|
|
|
|
showMoveAction :: Bool -> Key -> AssociatedFile -> Annex ()
|
|
showMoveAction move = showStart' (if move then "move" else "copy")
|
|
|
|
{- Moves (or copies) the content of an annexed file to a remote.
|
|
-
|
|
- If the remote already has the content, it is still removed from
|
|
- the current repository.
|
|
-
|
|
- Note that unlike drop, this does not honor numcopies.
|
|
- 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
|
|
u <- getUUID
|
|
ishere <- inAnnex key
|
|
if not ishere || u == Remote.uuid dest
|
|
then stop -- not here, so nothing to do
|
|
else toStart' dest move afile key
|
|
|
|
toStart' :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart
|
|
toStart' dest move afile key = do
|
|
fast <- Annex.getState Annex.fast
|
|
if fast && not move && not (Remote.hasKeyCheap dest)
|
|
then ifM (expectedPresent dest key)
|
|
( stop
|
|
, go True (pure $ Right False)
|
|
)
|
|
else go False (Remote.hasKey dest key)
|
|
where
|
|
go fastcheck isthere = do
|
|
showMoveAction move key afile
|
|
next $ toPerform dest move key afile fastcheck =<< isthere
|
|
|
|
expectedPresent :: Remote -> Key -> Annex Bool
|
|
expectedPresent dest key = do
|
|
remotes <- Remote.keyPossibilities key
|
|
return $ dest `elem` remotes
|
|
|
|
toPerform :: Remote -> Bool -> Key -> AssociatedFile -> Bool -> Either String Bool -> CommandPerform
|
|
toPerform dest move key afile fastcheck isthere =
|
|
case isthere of
|
|
Left err -> do
|
|
showNote err
|
|
stop
|
|
Right False -> do
|
|
showAction $ "to " ++ Remote.name dest
|
|
ok <- notifyTransfer Upload afile $
|
|
upload (Remote.uuid dest) key afile noRetry $
|
|
Remote.storeKey dest key afile
|
|
if ok
|
|
then do
|
|
Remote.logStatus dest key InfoPresent
|
|
finish
|
|
else do
|
|
when fastcheck $
|
|
warning "This could have failed because --fast is enabled."
|
|
stop
|
|
Right True -> do
|
|
unlessM (expectedPresent dest key) $
|
|
Remote.logStatus dest key InfoPresent
|
|
finish
|
|
where
|
|
finish
|
|
| move = lockContent key $ \contentlock -> do
|
|
removeAnnex contentlock
|
|
next $ Command.Drop.cleanupLocal key
|
|
| otherwise = next $ return True
|
|
|
|
{- Moves (or copies) the content of an annexed file from a remote
|
|
- to the current repository.
|
|
-
|
|
- 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
|
|
| move = go
|
|
| otherwise = stopUnless (not <$> inAnnex key) go
|
|
where
|
|
go = stopUnless (fromOk src key) $ do
|
|
showMoveAction move key afile
|
|
next $ fromPerform src move key afile
|
|
|
|
fromOk :: Remote -> Key -> Annex Bool
|
|
fromOk src key = go =<< Annex.getState Annex.force
|
|
where
|
|
go True = either (const $ return True) return =<< haskey
|
|
go False
|
|
| Remote.hasKeyCheap src =
|
|
either (const expensive) return =<< haskey
|
|
| otherwise = expensive
|
|
haskey = Remote.hasKey src key
|
|
expensive = do
|
|
u <- getUUID
|
|
remotes <- Remote.keyPossibilities key
|
|
return $ u /= Remote.uuid src && elem src remotes
|
|
|
|
fromPerform :: Remote -> Bool -> Key -> AssociatedFile -> CommandPerform
|
|
fromPerform src move key afile = ifM (inAnnex key)
|
|
( dispatch move True
|
|
, dispatch move =<< go
|
|
)
|
|
where
|
|
go = notifyTransfer Download afile $
|
|
download (Remote.uuid src) key afile noRetry $ \p -> do
|
|
showAction $ "from " ++ Remote.name src
|
|
getViaTmp key $ \t -> Remote.retrieveKeyFile src key afile t p
|
|
dispatch _ False = stop -- failed
|
|
dispatch False True = next $ return True -- copy complete
|
|
dispatch True True = do -- finish moving
|
|
ok <- Remote.removeKey src key
|
|
next $ Command.Drop.cleanupRemote key src ok
|