aboutsummaryrefslogtreecommitdiff
path: root/Command/Move.hs
blob: 41daab4b2611cc6344827161d0f141ab83e64b96 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
{- git-annex command
 -
 - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
 -
 - 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 qualified Option
import Logs.Presence
import Logs.Transfer

def :: [Command]
def = [withOptions options $ command "move" paramPaths seek
	"move content of files to/from another repository"]

fromOption :: Option
fromOption = Option.field ['f'] "from" paramRemote "source remote"

toOption :: Option
toOption = Option.field ['t'] "to" paramRemote "destination remote"

options :: [Option]
options = [fromOption, toOption]

seek :: [CommandSeek]
seek = [withField toOption Remote.byName $ \to ->
		withField fromOption Remote.byName $ \from ->
			withFilesInGit $ whenAnnexed $ start to from True]

start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> (Key, Backend) -> CommandStart
start to from move file (key, _) = do
	noAuto
	case (from, to) of
		(Nothing, Nothing) -> error "specify either --from or --to"
		(Nothing, Just dest) -> toStart dest move file key
		(Just src, Nothing) -> fromStart src move file key
		(_ ,  _) -> error "only one of --from or --to can be specified"
	where
		noAuto = when move $ whenM (Annex.getState Annex.auto) $ error
			"--auto is not supported for move"

showMoveAction :: Bool -> FilePath -> Annex ()
showMoveAction True file = showStart "move" file
showMoveAction False file = showStart "copy" file

{- 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 annex.numcopies.
 - A file's content can be moved even if there are insufficient copies to
 - allow it to be dropped.
 -}
toStart :: Remote -> Bool -> FilePath -> Key -> CommandStart
toStart dest move file key = do
	u <- getUUID
	ishere <- inAnnex key
	if not ishere || u == Remote.uuid dest
		then stop -- not here, so nothing to do
		else do
			showMoveAction move file
			next $ toPerform dest move key file
toPerform :: Remote -> Bool -> Key -> FilePath -> CommandPerform
toPerform dest move key file = moveLock move key $ do
	-- Checking the remote is expensive, so not done in the start step.
	-- In fast mode, location tracking is assumed to be correct,
	-- and an explicit check is not done, when copying. When moving,
	-- it has to be done, to avoid inaverdent data loss.
	fast <- Annex.getState Annex.fast
	let fastcheck = fast && not move && not (Remote.hasKeyCheap dest)
	isthere <- if fastcheck
		then do
			remotes <- Remote.keyPossibilities key
			return $ Right $ dest `elem` remotes
		else Remote.hasKey dest key
	case isthere of
		Left err -> do
			showNote err
			stop
		Right False -> do
			showAction $ "to " ++ Remote.name dest
			ok <- upload (Remote.uuid dest) key (Just file) noRetry $
				Remote.storeKey dest key (Just file)
			if ok
				then finish True
				else do
					when fastcheck $
						warning "This could have failed because --fast is enabled."
					stop
		Right True -> finish False
	where
		finish remotechanged = do
			when remotechanged $
				Remote.logStatus dest key InfoPresent
			if move
				then do
					whenM (inAnnex key) $ removeAnnex key
					next $ Command.Drop.cleanupLocal key
				else 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 -> FilePath -> Key -> CommandStart
fromStart src move file key
	| move = go
	| otherwise = stopUnless (not <$> inAnnex key) go
	where
		go = stopUnless (fromOk src key) $ do
			showMoveAction move file
			next $ fromPerform src move key file
fromOk :: Remote -> Key -> Annex Bool
fromOk src key
	| Remote.hasKeyCheap src =
		either (const expensive) return =<< Remote.hasKey src key
	| otherwise = expensive
	where
		expensive = do
			u <- getUUID
			remotes <- Remote.keyPossibilities key
			return $ u /= Remote.uuid src && elem src remotes
fromPerform :: Remote -> Bool -> Key -> FilePath -> CommandPerform
fromPerform src move key file = moveLock move key $
	ifM (inAnnex key)
		( handle move True
		, handle move =<< go
		)
	where
		go = download (Remote.uuid src) key (Just file) noRetry $ do
			showAction $ "from " ++ Remote.name src
			getViaTmp key $ Remote.retrieveKeyFile src key (Just file)
		handle _ False = stop -- failed
		handle False True = next $ return True -- copy complete
		handle True True = do -- finish moving
			ok <- Remote.removeKey src key
			next $ Command.Drop.cleanupRemote key src ok

{- Locks a key in order for it to be moved.
 - No lock is needed when a key is being copied. -}
moveLock :: Bool -> Key -> Annex a -> Annex a
moveLock True key a = lockContent key a
moveLock False _ a = a