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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
|
{- git-annex command infrastructure
-
- Copyright 2010-2011 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Command where
import Common.Annex
import qualified Backend
import qualified Annex
import qualified Git
import qualified Git.LsFiles as LsFiles
import Types.Key
import Logs.Trust
import Logs.Location
import Config
import Backend
import Limit
import Init
{- A command runs in these stages.
-
- a. The check stage runs checks, that error out if
- anything prevents the command from running. -}
type CommandCheck = Annex ()
{- b. The seek stage takes the parameters passed to the command,
- looks through the repo to find the ones that are relevant
- to that command (ie, new files to add), and generates
- a list of start stage actions. -}
type CommandSeek = [String] -> Annex [CommandStart]
{- c. The start stage is run before anything is printed about the
- command, is passed some input, and can early abort it
- if the input does not make sense. It should run quickly and
- should not modify Annex state. -}
type CommandStart = Annex (Maybe CommandPerform)
{- d. The perform stage is run after a message is printed about the command
- being run, and it should be where the bulk of the work happens. -}
type CommandPerform = Annex (Maybe CommandCleanup)
{- e. The cleanup stage is run only if the perform stage succeeds, and it
- returns the overall success/fail of the command. -}
type CommandCleanup = Annex Bool
data Command = Command {
cmdname :: String,
cmdparams :: String,
cmdcheck :: CommandCheck,
cmdseek :: [CommandSeek],
cmddesc :: String
}
{- For start and perform stages to indicate what step to run next. -}
next :: a -> Annex (Maybe a)
next a = return $ Just a
{- Or to indicate nothing needs to be done. -}
stop :: Annex (Maybe a)
stop = return Nothing
{- Checks that the command can be run in the current environment. -}
checkCommand :: Command -> Annex ()
checkCommand Command { cmdcheck = check } = check
{- Prepares a list of actions to run to perform a command, based on
- the parameters passed to it. -}
prepCommand :: Command -> [String] -> Annex [Annex Bool]
prepCommand Command { cmdseek = seek } params =
return . map doCommand . concat =<< mapM (\s -> s params) seek
{- Runs a command through the start, perform and cleanup stages -}
doCommand :: CommandStart -> CommandCleanup
doCommand = start
where
start = stage $ maybe success perform
perform = stage $ maybe failure cleanup
cleanup = stage $ \r -> showEndResult r >> return r
stage = (=<<)
success = return True
failure = showEndFail >> return False
notAnnexed :: FilePath -> Annex (Maybe a) -> Annex (Maybe a)
notAnnexed file a = maybe a (const $ return Nothing) =<< Backend.lookupFile file
isAnnexed :: FilePath -> ((Key, Backend Annex) -> Annex (Maybe a)) -> Annex (Maybe a)
isAnnexed file a = maybe (return Nothing) a =<< Backend.lookupFile file
notBareRepo :: Annex a -> Annex a
notBareRepo a = do
whenM (Git.repoIsLocalBare <$> gitRepo) $
error "You cannot run this subcommand in a bare repository."
a
{- These functions find appropriate files or other things based on a
user's parameters, and prepare actions operating on them. -}
withFilesInGit :: (FilePath -> CommandStart) -> CommandSeek
withFilesInGit a params = do
repo <- gitRepo
runFiltered a $ liftIO $ runPreserveOrder (LsFiles.inRepo repo) params
withAttrFilesInGit :: String -> ((FilePath, String) -> CommandStart) -> CommandSeek
withAttrFilesInGit attr a params = do
repo <- gitRepo
files <- liftIO $ runPreserveOrder (LsFiles.inRepo repo) params
runFilteredGen a fst $ liftIO $ Git.checkAttr repo attr files
withNumCopies :: (FilePath -> Maybe Int -> CommandStart) -> CommandSeek
withNumCopies a params = withAttrFilesInGit "annex.numcopies" go params
where
go (file, v) = a file (readMaybe v)
withBackendFilesInGit :: (BackendFile -> CommandStart) -> CommandSeek
withBackendFilesInGit a params = do
repo <- gitRepo
files <- liftIO $ runPreserveOrder (LsFiles.inRepo repo) params
backendPairs a files
withFilesMissing :: (String -> CommandStart) -> CommandSeek
withFilesMissing a params = runFiltered a $ liftIO $ filterM missing params
where
missing = liftM not . doesFileExist
withFilesNotInGit :: (BackendFile -> CommandStart) -> CommandSeek
withFilesNotInGit a params = do
repo <- gitRepo
force <- Annex.getState Annex.force
newfiles <- liftIO $ runPreserveOrder (LsFiles.notInRepo repo force) params
backendPairs a newfiles
withWords :: ([String] -> CommandStart) -> CommandSeek
withWords a params = return [a params]
withStrings :: (String -> CommandStart) -> CommandSeek
withStrings a params = return $ map a params
withFilesToBeCommitted :: (String -> CommandStart) -> CommandSeek
withFilesToBeCommitted a params = do
repo <- gitRepo
runFiltered a $
liftIO $ runPreserveOrder (LsFiles.stagedNotDeleted repo) params
withFilesUnlocked :: (BackendFile -> CommandStart) -> CommandSeek
withFilesUnlocked = withFilesUnlocked' LsFiles.typeChanged
withFilesUnlockedToBeCommitted :: (BackendFile -> CommandStart) -> CommandSeek
withFilesUnlockedToBeCommitted = withFilesUnlocked' LsFiles.typeChangedStaged
withFilesUnlocked' :: (Git.Repo -> [FilePath] -> IO [FilePath]) -> (BackendFile -> CommandStart) -> CommandSeek
withFilesUnlocked' typechanged a params = do
-- unlocked files have changed type from a symlink to a regular file
repo <- gitRepo
typechangedfiles <- liftIO $ runPreserveOrder (typechanged repo) params
unlockedfiles <- liftIO $ filterM notSymlink $
map (\f -> Git.workTree repo ++ "/" ++ f) typechangedfiles
backendPairs a unlockedfiles
withKeys :: (Key -> CommandStart) -> CommandSeek
withKeys a params = return $ map (a . parse) params
where
parse p = fromMaybe (error "bad key") $ readKey p
withNothing :: CommandStart -> CommandSeek
withNothing a [] = return [a]
withNothing _ _ = error "This command takes no parameters."
runFiltered :: (FilePath -> Annex (Maybe a)) -> Annex [FilePath] -> Annex [Annex (Maybe a)]
runFiltered a = runFilteredGen a id
backendPairs :: (BackendFile -> CommandStart) -> CommandSeek
backendPairs a fs = runFilteredGen a snd (Backend.chooseBackends fs)
runFilteredGen :: (b -> Annex (Maybe a)) -> (b -> FilePath) -> Annex [b] -> Annex [Annex (Maybe a)]
runFilteredGen a d fs = do
matcher <- Limit.getMatcher
liftM (map $ proc matcher) fs
where
proc matcher v = do
let f = d v
ok <- matcher f
if ok then a v else stop
{- filter out symlinks -}
notSymlink :: FilePath -> IO Bool
notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f
{- Descriptions of params used in usage messages. -}
paramPaths :: String
paramPaths = paramOptional $ paramRepeating paramPath -- most often used
paramPath :: String
paramPath = "PATH"
paramKey :: String
paramKey = "KEY"
paramDesc :: String
paramDesc = "DESC"
paramUrl :: String
paramUrl = "URL"
paramNumber :: String
paramNumber = "NUMBER"
paramRemote :: String
paramRemote = "REMOTE"
paramGlob :: String
paramGlob = "GLOB"
paramName :: String
paramName = "NAME"
paramUUID :: String
paramUUID = "UUID"
paramType :: String
paramType = "TYPE"
paramKeyValue :: String
paramKeyValue = "K=V"
paramNothing :: String
paramNothing = ""
paramRepeating :: String -> String
paramRepeating s = s ++ " ..."
paramOptional :: String -> String
paramOptional s = "[" ++ s ++ "]"
paramPair :: String -> String -> String
paramPair a b = a ++ " " ++ b
{- The Key specified by the --key parameter. -}
cmdlineKey :: Annex Key
cmdlineKey = do
k <- Annex.getState Annex.defaultkey
case k of
Nothing -> nokey
Just "" -> nokey
Just kstring -> maybe badkey return $ readKey kstring
where
nokey = error "please specify the key with --key"
badkey = error "bad key"
{- Used for commands that have an auto mode that checks the number of known
- copies of a key.
-
- In auto mode, first checks that the number of known
- copies of the key is > or < than the numcopies setting, before running
- the action. -}
autoCopies :: Key -> (Int -> Int -> Bool) -> Maybe Int -> CommandStart -> CommandStart
autoCopies key vs numcopiesattr a = do
auto <- Annex.getState Annex.auto
if auto
then do
needed <- getNumCopies numcopiesattr
(_, have) <- trustPartition UnTrusted =<< keyLocations key
if length have `vs` needed then a else stop
else a
{- Checks -}
defaultChecks :: CommandCheck
defaultChecks = noFrom >> noTo >> needsRepo
noChecks :: CommandCheck
noChecks = return ()
needsRepo :: CommandCheck
needsRepo = ensureInitialized
noFrom :: CommandCheck
noFrom = do
v <- Annex.getState Annex.fromremote
unless (v == Nothing) $ error "cannot use --from with this command"
noTo :: CommandCheck
noTo = do
v <- Annex.getState Annex.toremote
unless (v == Nothing) $ error "cannot use --to with this command"
|
