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 BackendList
import UUID
import LocationLog
import Types
import Core
import qualified Remotes
{- Parses command line and returns a list of flags and a list of
- actions to be run in the Annex monad. -}
parseCmd :: [String] -> IO ([Flag], [Annex ()])
parseCmd argv = do
(flags, files) <- getopt
case (length files) of
0 -> error header
_ -> do
let c = lookupCmd (files !! 0)
if (0 == length c)
then ret flags defaultCmd files
else ret flags (snd $ c !! 0) $ drop 1 files
where
ret flags cmd files = return (flags, makeactions cmd files)
makeactions cmd files = map cmd files
getopt = case getOpt Permute options argv of
(flags, nonopts, []) -> return (flags, nonopts)
(_, _, errs) -> ioError (userError (concat errs ++ usageInfo header options))
lookupCmd cmd = filter (\(c, a) -> c == cmd) cmds
cmds = [ ("add", addCmd)
, ("get", getCmd)
, ("drop", dropCmd)
, ("want", wantCmd)
, ("push", pushCmd)
, ("pull", pullCmd)
, ("unannex", unannexCmd)
]
header = "Usage: git-annex [" ++
(join "|" $ map fst cmds) ++ "] file ..."
options = [ Option ['f'] ["force"] (NoArg Force) "allow actions that may loose annexed data" ]
{- Default mode is to annex a file if it is not already, and otherwise
- get its content. -}
defaultCmd :: FilePath -> Annex ()
defaultCmd file = do
r <- liftIO $ Backend.lookupFile file
case (r) of
Just v -> getCmd file
Nothing -> addCmd file
{- 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
g <- Annex.gitRepo
link <- liftIO $ calcGitLink file g
stored <- Backend.storeFileKey file
case (stored) of
Nothing -> error $ "no backend could store: " ++ file
Just (key, backend) -> do
logStatus key ValuePresent
liftIO $ setup g key link
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 ()
calcGitLink file g = do
cwd <- getCurrentDirectory
let absfile = case (absNormPath cwd file) of
Just f -> f
Nothing -> error $ "unable to normalize " ++ file
return $ relPathDirToDir (parentDir absfile) (Git.workTree g)
setup g key link = do
let dest = annexLocation g key
let reldest = annexLocationRelative g key
createDirectoryIfMissing True (parentDir dest)
renameFile file dest
createSymbolicLink (link ++ reldest) file
Git.run g ["add", file]
Git.run g ["commit", "-m",
("git-annex annexed " ++ file), file]
{- Inverse of addCmd. -}
unannexCmd :: FilePath -> Annex ()
unannexCmd file = notinBackend file err $ \(key, backend) -> do
Backend.removeKey backend key
logStatus key ValueMissing
g <- Annex.gitRepo
let src = annexLocation g key
liftIO $ moveout g src
where
err = error $ "not annexed " ++ file
moveout g src = do
removeFile file
Git.run g ["rm", file]
Git.run g ["commit", "-m",
("git-annex unannexed " ++ file), file]
-- git rm deletes empty directories;
-- put them back
createDirectoryIfMissing True (parentDir file)
renameFile src file
return ()
{- 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
g <- Annex.gitRepo
let dest = annexLocation g key
liftIO $ createDirectoryIfMissing True (parentDir dest)
success <- Backend.retrieveKeyFile backend key dest
if (success)
then do
logStatus key ValuePresent
return ()
else error $ "failed to get " ++ file
where
err = error $ "not annexed " ++ file
{- Indicates a file is wanted. -}
wantCmd :: FilePath -> Annex ()
wantCmd file = do error "not implemented" -- TODO
{- Indicates a file is not wanted. -}
dropCmd :: FilePath -> Annex ()
dropCmd file = notinBackend file err $ \(key, backend) -> do
force <- Annex.flagIsSet Force
if (not force)
then requireEnoughCopies key
else return ()
success <- Backend.removeKey backend key
if (success)
then 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 ()
else error $ "backend refused to drop " ++ file
where
err = error $ "not annexed " ++ file
{- Pushes all files to a remote repository. -}
pushCmd :: String -> Annex ()
pushCmd reponame = do error "not implemented" -- TODO
{- Pulls all files from a remote repository. -}
pullCmd :: String -> Annex ()
pullCmd reponame = do error "not implemented" -- TODO
{- Updates the LocationLog when a key's presence changes. -}
logStatus :: Key -> LogStatus -> Annex ()
logStatus key status = do
g <- Annex.gitRepo
u <- getUUID g
f <- liftIO $ logChange g key u status
liftIO $ Git.run g ["add", f]
Annex.flagChange NeedCommit True
inBackend file yes no = do
r <- liftIO $ Backend.lookupFile file
case (r) of
Just v -> yes v
Nothing -> no
notinBackend file yes no = inBackend file no yes
{- Checks remotes to verify that enough copies of a key exist to allow
- for a key to be safely removed (with no data loss), and fails with an
- error if not. -}
requireEnoughCopies :: Key -> Annex ()
requireEnoughCopies key = do
g <- Annex.gitRepo
let numcopies = read $ Git.configGet g config "1"
remotes <- Remotes.withKey key
if (numcopies > length remotes)
then error $ "I only know about " ++ (show $ length remotes) ++
" out of " ++ (show numcopies) ++
" necessary copies of: " ++ (keyFile key) ++
unsafe
else findcopies numcopies remotes []
where
findcopies 0 _ _ = return () -- success, enough copies found
findcopies _ [] bad = die bad
findcopies n (r:rs) bad = do
result <- liftIO $ try $ haskey r
case (result) of
Right True -> findcopies (n-1) rs bad
Right False -> findcopies n rs bad
Left _ -> findcopies n rs (r:bad)
haskey r = do
-- To check if a remote has a key, construct a new
-- Annex monad and query its backend.
a <- Annex.new r
(result, _) <- Annex.run a (Backend.hasKey key)
return result
die bad =
error $ "I failed to find enough other copies of: " ++
(keyFile key) ++
(if (0 /= length bad) then listbad bad else "")
++ unsafe
listbad bad = "\nI was unable to access these remotes: " ++
(Remotes.list bad)
unsafe = "\n" ++
" -- According to the " ++ config ++
" setting, it is not safe to remove it!\n" ++
" (Use --force to override.)"
config = "annex.numcopies"
|
