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
|
{- git-annex key/value backends
-
- Copyright 2010,2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Backend (
list,
orderedList,
genKey,
lookupFile,
isAnnexLink,
makeAnnexLink,
chooseBackend,
lookupBackendName,
maybeLookupBackendName
) where
import System.Posix.Files
import Common.Annex
import qualified Annex
import Annex.CheckAttr
import Annex.CatFile
import Types.Key
import Types.KeySource
import qualified Types.Backend as B
import Config
-- When adding a new backend, import it here and add it to the list.
import qualified Backend.SHA
import qualified Backend.WORM
import qualified Backend.URL
list :: [Backend]
list = Backend.SHA.backends ++ Backend.WORM.backends ++ Backend.URL.backends
{- List of backends in the order to try them when storing a new key. -}
orderedList :: Annex [Backend]
orderedList = do
l <- Annex.getState Annex.backends -- list is cached here
if not $ null l
then return l
else do
f <- Annex.getState Annex.forcebackend
case f of
Just name | not (null name) ->
return [lookupBackendName name]
_ -> do
l' <- gen . annexBackends <$> Annex.getGitConfig
Annex.changeState $ \s -> s { Annex.backends = l' }
return l'
where
gen [] = list
gen l = map lookupBackendName l
{- Generates a key for a file, trying each backend in turn until one
- accepts it. -}
genKey :: KeySource -> Maybe Backend -> Annex (Maybe (Key, Backend))
genKey source trybackend = do
bs <- orderedList
let bs' = maybe bs (: bs) trybackend
genKey' bs' source
genKey' :: [Backend] -> KeySource -> Annex (Maybe (Key, Backend))
genKey' [] _ = return Nothing
genKey' (b:bs) source = do
r <- B.getKey b source
case r of
Nothing -> genKey' bs source
Just k -> return $ Just (makesane k, b)
where
-- keyNames should not contain newline characters.
makesane k = k { keyName = map fixbadchar (keyName k) }
fixbadchar c
| c == '\n' = '_'
| otherwise = c
{- Looks up the key and backend corresponding to an annexed file,
- by examining what the file symlinks to.
-
- In direct mode, there is often no symlink on disk, in which case
- the symlink is looked up in git instead. However, a real symlink
- on disk still takes precedence over what was committed to git in direct
- mode.
-
- On a filesystem that does not support symlinks, git will instead store
- the symlink target in a regular file.
-}
lookupFile :: FilePath -> Annex (Maybe (Key, Backend))
lookupFile file = do
mkey <- isAnnexLink file
case mkey of
Just key -> makeret key
Nothing -> ifM isDirect
( maybe (return Nothing) makeret =<< catKeyFile file
, return Nothing
)
where
makeret k = let bname = keyBackendName k in
case maybeLookupBackendName bname of
Just backend -> do
return $ Just (k, backend)
Nothing -> do
warning $
"skipping " ++ file ++
" (unknown backend " ++ bname ++ ")"
return Nothing
{- Checks if a file is a symlink to a key.
-
- On a filesystem that does not support symlinks, git will instead store
- the symlink target in a regular file. (Only look at first 8k of file,
- more than enough for any symlink target.)
-}
isAnnexLink :: FilePath -> Annex (Maybe Key)
isAnnexLink file = maybe Nothing makekey <$> gettarget
where
gettarget = ifM (coreSymlinks <$> Annex.getGitConfig)
( liftIO $ catchMaybeIO $ readSymbolicLink file
, liftIO $ catchMaybeIO $ take 8192 <$> readFile file
)
makekey l
| isLinkToAnnex l = fileKey $ takeFileName l
| otherwise = Nothing
{- Creates a symlink on disk.
-
- On a filesystem that does not support symlinks, writes the link target
- to a file. Note that git will only treat the file as a symlink if
- it's staged as such.
-}
makeAnnexLink :: String -> FilePath -> Annex ()
makeAnnexLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
( liftIO $ createSymbolicLink linktarget file
, liftIO $ writeFile file linktarget
)
{- Looks up the backend that should be used for a file.
- That can be configured on a per-file basis in the gitattributes file. -}
chooseBackend :: FilePath -> Annex (Maybe Backend)
chooseBackend f = Annex.getState Annex.forcebackend >>= go
where
go Nothing = maybeLookupBackendName <$> checkAttr "annex.backend" f
go (Just _) = Just . Prelude.head <$> orderedList
{- Looks up a backend by name. May fail if unknown. -}
lookupBackendName :: String -> Backend
lookupBackendName s = fromMaybe unknown $ maybeLookupBackendName s
where
unknown = error $ "unknown backend " ++ s
maybeLookupBackendName :: String -> Maybe Backend
maybeLookupBackendName s = headMaybe matches
where
matches = filter (\b -> s == B.name b) list
|
