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
|
{- git-annex command line -}
module Commands (parseCmd) where
import System.Console.GetOpt
import Control.Monad.State (liftIO)
import System.Posix.Files
import System.Directory
import System.Path
import Data.String.Utils
import List
import IO
import qualified GitRepo as Git
import qualified Annex
import Utility
import Locations
import qualified Backend
import UUID
import LocationLog
import Types
import Core
import qualified Remotes
import qualified BackendTypes
data CmdWants = FilesInGit | FilesNotInGit | FilesInOrNotInGit |
RepoName | SingleString
data Command = Command {
cmdname :: String,
cmdaction :: (String -> Annex ()),
cmdwants :: CmdWants
}
cmds :: [Command]
cmds = [
(Command "add" addCmd FilesNotInGit)
, (Command "get" getCmd FilesInGit)
, (Command "drop" dropCmd FilesInGit)
, (Command "unannex" unannexCmd FilesInGit)
, (Command "describe" describeCmd SingleString)
, (Command "fix" fixCmd FilesInOrNotInGit)
]
options = [
Option ['f'] ["force"] (NoArg Force) "allow actions that may loose annexed data"
, Option ['N'] ["no-commit"] (NoArg NoCommit) "do not stage or commit changes"
]
{- Finds the type of parameters a command wants, from among the passed
- parameter list. -}
findWanted :: CmdWants -> [String] -> Git.Repo -> IO [String]
findWanted FilesNotInGit params repo = do
files <- mapM (Git.notInRepo repo) params
return $ foldl (++) [] files
findWanted FilesInGit params repo = do
files <- mapM (Git.inRepo repo) params
return $ foldl (++) [] files
findWanted FilesInOrNotInGit params repo = do
a <- findWanted FilesInGit params repo
b <- findWanted FilesNotInGit params repo
return $ union a b
findWanted SingleString params _ = do
return $ [unwords params]
findWanted RepoName params _ = do
return $ params
{- Parses command line and returns a list of flags and a list of
- actions to be run in the Annex monad. -}
parseCmd :: [String] -> AnnexState -> IO ([Flag], [Annex ()])
parseCmd argv state = do
(flags, params) <- getopt
case (length params) of
0 -> error usage
_ -> case (lookupCmd (params !! 0)) of
[] -> error usage
[Command _ action want] -> do
f <- findWanted want (drop 1 params)
(BackendTypes.repo state)
return (flags, map action $ filter notstate f)
where
-- never include files from the state directory
notstate f = stateLoc /= take (length stateLoc) f
getopt = case getOpt Permute options argv of
(flags, params, []) -> return (flags, params)
(_, _, errs) -> ioError (userError (concat errs ++ usage))
lookupCmd cmd = filter (\c -> cmd == cmdname c) cmds
header = "Usage: git-annex [" ++
(join "|" $ map cmdname cmds) ++ "] ..."
usage = usageInfo header options
{- Annexes a file, storing it in a backend, and then moving it into
- the annex directory and setting up the symlink pointing to its content. -}
addCmd :: FilePath -> Annex ()
addCmd file = inBackend file err $ do
liftIO $ checkLegal file
showStart "add" file
g <- Annex.gitRepo
stored <- Backend.storeFileKey file
case (stored) of
Nothing -> showEndFail "no backend could store" file
Just (key, backend) -> do
logStatus key ValuePresent
setup g key
where
err = error $ "already annexed " ++ file
checkLegal file = do
s <- getSymbolicLinkStatus file
if ((isSymbolicLink s) || (not $ isRegularFile s))
then error $ "not a regular file: " ++ file
else return ()
setup g key = do
let dest = annexLocation g key
liftIO $ createDirectoryIfMissing True (parentDir dest)
liftIO $ renameFile file dest
link <- calcGitLink file key
liftIO $ createSymbolicLink link file
gitAdd file $ Just $ "git-annex annexed " ++ file
showEndOk
{- Undo addCmd. -}
unannexCmd :: FilePath -> Annex ()
unannexCmd file = notinBackend file err $ \(key, backend) -> do
showStart "unannex" file
Annex.flagChange Force True -- force backend to always remove
Backend.removeKey backend key
logStatus key ValueMissing
g <- Annex.gitRepo
let src = annexLocation g key
moveout g src
where
err = error $ "not annexed " ++ file
moveout g src = do
nocommit <- Annex.flagIsSet NoCommit
liftIO $ removeFile file
liftIO $ Git.run g ["rm", "--quiet", file]
if (not nocommit)
then liftIO $ Git.run g ["commit", "--quiet",
"-m", ("git-annex unannexed " ++ file),
file]
else return ()
-- git rm deletes empty directories;
-- put them back
liftIO $ createDirectoryIfMissing True (parentDir file)
liftIO $ renameFile src file
showEndOk
{- Gets an annexed file from one of the backends. -}
getCmd :: FilePath -> Annex ()
getCmd file = notinBackend file err $ \(key, backend) -> do
inannex <- inAnnex key
if (inannex)
then return ()
else do
showStart "get" file
g <- Annex.gitRepo
let dest = annexLocation g key
let tmp = (annexTmpLocation g) ++ (keyFile key)
liftIO $ createDirectoryIfMissing True (parentDir tmp)
success <- Backend.retrieveKeyFile backend key tmp
if (success)
then do
liftIO $ renameFile tmp dest
logStatus key ValuePresent
showEndOk
else do
showEndFail "get" file
where
err = error $ "not annexed " ++ file
{- Indicates a file's content is not wanted anymore, and should be removed
- if it's safe to do so. -}
dropCmd :: FilePath -> Annex ()
dropCmd file = notinBackend file err $ \(key, backend) -> do
inbackend <- Backend.hasKey key
if (not inbackend)
then return () -- no-op
else do
showStart "drop" file
success <- Backend.removeKey backend key
if (success)
then do
cleanup key
showEndOk
else showEndFail "backend refused to drop" file
where
cleanup key = do
logStatus key ValueMissing
inannex <- inAnnex key
if (inannex)
then do
g <- Annex.gitRepo
let loc = annexLocation g key
liftIO $ removeFile loc
return ()
else return ()
err = error $ "not annexed " ++ file
{- Fixes the symlink to an annexed file. -}
fixCmd :: String -> Annex ()
fixCmd file = notinBackend file err $ \(key, backend) -> do
link <- calcGitLink file key
checkLegal file link
showStart "fix" file
liftIO $ createDirectoryIfMissing True (parentDir file)
liftIO $ removeFile file
liftIO $ createSymbolicLink link file
gitAdd file $ Just $ "git-annex fix " ++ file
showEndOk
where
checkLegal file link = do
l <- liftIO $ readSymbolicLink file
if (link == l)
then error $ "symbolic link already ok for: " ++ file
else return ()
err = error $ "not annexed " ++ file
{- Stores description for the repository. -}
describeCmd :: String -> Annex ()
describeCmd description = do
g <- Annex.gitRepo
u <- getUUID g
describeUUID u description
log <- uuidLog
gitAdd log $ Just $ "description for UUID " ++ (show u)
liftIO $ putStrLn "description set"
-- helpers
inBackend file yes no = do
r <- Backend.lookupFile file
case (r) of
Just v -> yes v
Nothing -> no
notinBackend file yes no = inBackend file no yes
|
