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
|
{- git-annex key-value storage backends
-
- git-annex uses a key-value abstraction layer to allow files contents to be
- stored in different ways. In theory, any key-value storage system could be
- used to store the file contents, and git-annex would then retrieve them
- as needed and put them in `.git/annex/`.
-
- When a file is annexed, a key is generated from its content and/or metadata.
- This key can later be used to retrieve the file's content (its value). This
- key generation must be stable for a given file content, name, and size.
-
- Multiple pluggable backends are supported, and more than one can be used
- to store different files' contents in a given repository.
-
- Copyright 2010 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Backend (
list,
storeFileKey,
retrieveKeyFile,
removeKey,
hasKey,
fsckKey,
upgradableKey,
lookupFile,
chooseBackends,
keyBackend,
lookupBackendName,
maybeLookupBackendName
) where
import Control.Monad.State (liftIO, when)
import System.IO.Error (try)
import System.FilePath
import System.Posix.Files
import System.Directory
import Locations
import qualified GitRepo as Git
import qualified Annex
import Types
import Key
import qualified BackendClass as B
import Messages
import Content
import DataUnits
{- List of backends in the order to try them when storing a new key. -}
list :: Annex [Backend Annex]
list = do
l <- Annex.getState Annex.backends -- list is cached here
if not $ null l
then return l
else do
s <- getstandard
d <- Annex.getState Annex.defaultbackend
handle d s
where
parseBackendList l [] = l
parseBackendList bs s = map (lookupBackendName bs) $ words s
handle Nothing s = return s
handle (Just "") s = return s
handle (Just name) s = do
bs <- Annex.getState Annex.supportedBackends
let l' = (lookupBackendName bs name):s
Annex.changeState $ \state -> state { Annex.backends = l' }
return l'
getstandard = do
bs <- Annex.getState Annex.supportedBackends
g <- Annex.gitRepo
return $ parseBackendList bs $
Git.configGet g "annex.backends" ""
{- Looks up a backend in a list. May fail if unknown. -}
lookupBackendName :: [Backend Annex] -> String -> Backend Annex
lookupBackendName bs s =
case maybeLookupBackendName bs s of
Just b -> b
Nothing -> error $ "unknown backend " ++ s
maybeLookupBackendName :: [Backend Annex] -> String -> Maybe (Backend Annex)
maybeLookupBackendName bs s =
if 1 /= length matches
then Nothing
else Just $ head matches
where matches = filter (\b -> s == B.name b) bs
{- Attempts to store a file in one of the backends. -}
storeFileKey :: FilePath -> Maybe (Backend Annex) -> Annex (Maybe (Key, Backend Annex))
storeFileKey file trybackend = do
bs <- list
let bs' = case trybackend of
Nothing -> bs
Just backend -> backend:bs
storeFileKey' bs' file
storeFileKey' :: [Backend Annex] -> FilePath -> Annex (Maybe (Key, Backend Annex))
storeFileKey' [] _ = return Nothing
storeFileKey' (b:bs) file = do
result <- (B.getKey b) file
case result of
Nothing -> nextbackend
Just key -> do
stored <- (B.storeFileKey b) file key
if (not stored)
then nextbackend
else return $ Just (key, b)
where
nextbackend = storeFileKey' bs file
{- Attempts to retrieve an key from one of the backends, saving it to
- a specified location. -}
retrieveKeyFile :: Backend Annex -> Key -> FilePath -> Annex Bool
retrieveKeyFile backend key dest = (B.retrieveKeyFile backend) key dest
{- Removes a key from a backend. -}
removeKey :: Backend Annex -> Key -> Maybe Int -> Annex Bool
removeKey backend key numcopies = (B.removeKey backend) key numcopies
{- Checks if a key is present in its backend. -}
hasKey :: Key -> Annex Bool
hasKey key = do
backend <- keyBackend key
(B.hasKey backend) key
{- Checks a key for problems. -}
fsckKey :: Backend Annex -> Key -> Maybe FilePath -> Maybe Int -> Annex Bool
fsckKey backend key file numcopies = do
size_ok <- checkKeySize key
backend_ok <-(B.fsckKey backend) key file numcopies
return $ size_ok && backend_ok
{- Checks if a key is upgradable to a newer representation. -}
upgradableKey :: Backend Annex -> Key -> Annex Bool
upgradableKey backend key = (B.upgradableKey backend) key
{- Looks up the key and backend corresponding to an annexed file,
- by examining what the file symlinks to. -}
lookupFile :: FilePath -> Annex (Maybe (Key, Backend Annex))
lookupFile file = do
bs <- Annex.getState Annex.supportedBackends
tl <- liftIO $ try getsymlink
case tl of
Left _ -> return Nothing
Right l -> makekey bs l
where
getsymlink = do
l <- readSymbolicLink file
return $ takeFileName l
makekey bs l =
case fileKey l of
Just k -> makeret k l bs
Nothing -> return Nothing
makeret k l bs =
case maybeLookupBackendName bs bname of
Just backend -> return $ Just (k, backend)
Nothing -> do
when (isLinkToAnnex l) $
warning skip
return Nothing
where
bname = keyBackendName k
skip = "skipping " ++ file ++
" (unknown backend " ++ bname ++ ")"
{- Looks up the backends that should be used for each file in a list.
- That can be configured on a per-file basis in the gitattributes file.
-}
chooseBackends :: [FilePath] -> Annex [(FilePath, Maybe (Backend Annex))]
chooseBackends fs = do
g <- Annex.gitRepo
bs <- Annex.getState Annex.supportedBackends
pairs <- liftIO $ Git.checkAttr g "annex.backend" fs
return $ map (\(f,b) -> (f, maybeLookupBackendName bs b)) pairs
{- Returns the backend to use for a key. -}
keyBackend :: Key -> Annex (Backend Annex)
keyBackend key = do
bs <- Annex.getState Annex.supportedBackends
return $ lookupBackendName bs $ keyBackendName key
{- The size of the data for a key is checked against the size encoded in
- the key's metadata, if available. -}
checkKeySize :: Key -> Annex Bool
checkKeySize key = do
g <- Annex.gitRepo
let file = gitAnnexLocation g key
present <- liftIO $ doesFileExist file
case (present, keySize key) of
(_, Nothing) -> return True
(False, _) -> return True
(True, Just size) -> do
stat <- liftIO $ getFileStatus file
let size' = fromIntegral (fileSize stat)
if size == size'
then return True
else do
dest <- moveBad key
warning $ "Bad file size (" ++
compareSizes storageUnits True size size' ++
"); moved to " ++ dest
return False
|
