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
|
{- git-annex command seeking
-
- These functions find appropriate files or other things based on
- the values a user passes to a command, and prepare actions operating
- on them.
-
- Copyright 2010-2014 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module CmdLine.Seek where
import Common.Annex
import Types.Command
import Types.Key
import Types.FileMatcher
import qualified Annex
import qualified Git
import qualified Git.Command
import qualified Git.LsFiles as LsFiles
import qualified Git.LsTree as LsTree
import Git.FilePath
import qualified Limit
import CmdLine.Option
import CmdLine.Action
import Logs.Location
import Logs.Unused
import Annex.CatFile
withFilesInGit :: (FilePath -> CommandStart) -> CommandSeek
withFilesInGit a params = seekActions $ prepFiltered a $
seekHelper LsFiles.inRepo params
withFilesNotInGit :: Bool -> (FilePath -> CommandStart) -> CommandSeek
withFilesNotInGit skipdotfiles a params
| skipdotfiles = do
{- dotfiles are not acted on unless explicitly listed -}
files <- filter (not . dotfile) <$>
seekunless (null ps && not (null params)) ps
dotfiles <- seekunless (null dotps) dotps
go (files++dotfiles)
| otherwise = go =<< seekunless False params
where
(dotps, ps) = partition dotfile params
seekunless True _ = return []
seekunless _ l = do
force <- Annex.getState Annex.force
g <- gitRepo
liftIO $ Git.Command.leaveZombie <$> LsFiles.notInRepo force l g
go l = seekActions $ prepFiltered a $
return $ concat $ segmentPaths params l
withFilesInRefs :: (FilePath -> Key -> CommandStart) -> CommandSeek
withFilesInRefs a = mapM_ go
where
go r = do
matcher <- Limit.getMatcher
l <- inRepo $ LsTree.lsTree (Git.Ref r)
forM_ l $ \i -> do
let f = getTopFilePath $ LsTree.file i
v <- catKey (Git.Ref $ LsTree.sha i) (LsTree.mode i)
case v of
Nothing -> noop
Just k -> whenM (matcher $ MatchingKey k) $
void $ commandAction $ a f k
withPathContents :: ((FilePath, FilePath) -> CommandStart) -> CommandSeek
withPathContents a params = do
matcher <- Limit.getMatcher
seekActions $ map a <$> (filterM (checkmatch matcher) =<< ps)
where
ps = concat <$> liftIO (mapM get params)
get p = ifM (isDirectory <$> getFileStatus p)
( map (\f -> (f, makeRelative (parentDir p) f))
<$> dirContentsRecursiveSkipping (".git" `isSuffixOf`) True p
, return [(p, takeFileName p)]
)
checkmatch matcher (f, relf) = matcher $ MatchingFile $ FileInfo
{ relFile = f
, matchFile = relf
}
withWords :: ([String] -> CommandStart) -> CommandSeek
withWords a params = seekActions $ return [a params]
withStrings :: (String -> CommandStart) -> CommandSeek
withStrings a params = seekActions $ return $ map a params
withPairs :: ((String, String) -> CommandStart) -> CommandSeek
withPairs a params = seekActions $ return $ map a $ pairs [] params
where
pairs c [] = reverse c
pairs c (x:y:xs) = pairs ((x,y):c) xs
pairs _ _ = error "expected pairs"
withFilesToBeCommitted :: (String -> CommandStart) -> CommandSeek
withFilesToBeCommitted a params = seekActions $ prepFiltered a $
seekHelper LsFiles.stagedNotDeleted params
withFilesUnlocked :: (FilePath -> CommandStart) -> CommandSeek
withFilesUnlocked = withFilesUnlocked' LsFiles.typeChanged
withFilesUnlockedToBeCommitted :: (FilePath -> CommandStart) -> CommandSeek
withFilesUnlockedToBeCommitted = withFilesUnlocked' LsFiles.typeChangedStaged
{- Unlocked files have changed type from a symlink to a regular file.
-
- Furthermore, unlocked files used to be a git-annex symlink,
- not some other sort of symlink.
-}
withFilesUnlocked' :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> (FilePath -> CommandStart) -> CommandSeek
withFilesUnlocked' typechanged a params = seekActions $
prepFiltered a unlockedfiles
where
unlockedfiles = filterM isUnlocked =<< seekHelper typechanged params
isUnlocked :: FilePath -> Annex Bool
isUnlocked f = liftIO (notSymlink f) <&&>
(isJust <$> catKeyFile f <||> isJust <$> catKeyFileHEAD f)
{- Finds files that may be modified. -}
withFilesMaybeModified :: (FilePath -> CommandStart) -> CommandSeek
withFilesMaybeModified a params = seekActions $
prepFiltered a $ seekHelper LsFiles.modified params
withKeys :: (Key -> CommandStart) -> CommandSeek
withKeys a params = seekActions $ return $ map (a . parse) params
where
parse p = fromMaybe (error "bad key") $ file2key p
{- Gets the value of a field options, which is fed into
- a conversion function.
-}
getOptionField :: Option -> (Maybe String -> Annex a) -> Annex a
getOptionField option converter = converter <=< Annex.getField $ optionName option
getOptionFlag :: Option -> Annex Bool
getOptionFlag option = Annex.getFlag (optionName option)
withNothing :: CommandStart -> CommandSeek
withNothing a [] = seekActions $ return [a]
withNothing _ _ = error "This command takes no parameters."
{- If --all is specified, or in a bare repo, runs an action on all
- known keys.
-
- If --unused is specified, runs an action on all keys found by
- the last git annex unused scan.
-
- If --key is specified, operates only on that key.
-
- Otherwise, fall back to a regular CommandSeek action on
- whatever params were passed. -}
withKeyOptions :: (Key -> CommandStart) -> CommandSeek -> CommandSeek
withKeyOptions keyop fallbackop params = do
bare <- fromRepo Git.repoIsLocalBare
allkeys <- Annex.getFlag "all"
unused <- Annex.getFlag "unused"
specifickey <- Annex.getField "key"
auto <- Annex.getState Annex.auto
when (auto && bare) $
error "Cannot use --auto in a bare repository"
case (allkeys, unused, null params, specifickey) of
(False , False , True , Nothing)
| bare -> go auto loggedKeys
| otherwise -> fallbackop params
(False , False , _ , Nothing) -> fallbackop params
(True , False , True , Nothing) -> go auto loggedKeys
(False , True , True , Nothing) -> go auto unusedKeys'
(False , False , True , Just ks) -> case file2key ks of
Nothing -> error "Invalid key"
Just k -> go auto $ return [k]
_ -> error "Can only specify one of file names, --all, --unused, or --key"
where
go True _ = error "Cannot use --auto with --all or --unused or --key"
go False a = do
matcher <- Limit.getMatcher
seekActions $ map (process matcher) <$> a
process matcher k = ifM (matcher $ MatchingKey k)
( keyop k , return Nothing)
prepFiltered :: (FilePath -> CommandStart) -> Annex [FilePath] -> Annex [CommandStart]
prepFiltered a fs = do
matcher <- Limit.getMatcher
map (process matcher) <$> fs
where
process matcher f = ifM (matcher $ MatchingFile $ FileInfo f f)
( a f , return Nothing )
seekActions :: Annex [CommandStart] -> Annex ()
seekActions gen = do
as <- gen
mapM_ commandAction as
seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [FilePath] -> Annex [FilePath]
seekHelper a params = do
ll <- inRepo $ \g ->
runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g) params
forM_ (map fst $ filter (null . snd) $ zip params ll) $ \p ->
unlessM (isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)) $
error $ p ++ " not found"
return $ concat ll
notSymlink :: FilePath -> IO Bool
notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f
|
