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
|
{- Using bup as a remote.
-
- Copyright 2011 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Remote.Bup (remote) where
import IO
import Control.Exception.Extensible (IOException)
import qualified Data.Map as M
import Control.Monad (unless, when)
import Control.Monad.State (liftIO)
import System.Process
import System.Exit
import System.FilePath
import Data.List.Utils
import RemoteClass
import Types
import qualified GitRepo as Git
import qualified Annex
import UUID
import Locations
import LocationLog
import Config
import Utility
import Messages
import Remote.Special
import Ssh
remote :: RemoteType Annex
remote = RemoteType {
typename = "bup",
enumerate = findSpecialRemotes "buprepo",
generate = gen,
setup = bupSetup
}
gen :: Git.Repo -> UUID -> Maybe (M.Map String String) -> Annex (Remote Annex)
gen r u c = do
buprepo <- getConfig r "buprepo" (error "missing buprepo")
cst <- remoteCost r (if bupLocal buprepo then semiCheapRemoteCost else expensiveRemoteCost)
u' <- getBupUUID buprepo u
return $ this cst buprepo u'
where
this cst buprepo u' = Remote {
uuid = u',
cost = cst,
name = Git.repoDescribe r,
storeKey = store r buprepo,
retrieveKeyFile = retrieve buprepo,
removeKey = remove,
hasKey = checkPresent u',
hasKeyCheap = True,
config = c
}
bupSetup :: UUID -> M.Map String String -> Annex (M.Map String String)
bupSetup u c = do
-- verify configuration is sane
let buprepo = case M.lookup "buprepo" c of
Nothing -> error "Specify buprepo="
Just r -> r
case M.lookup "encryption" c of
Nothing -> error "Specify encryption=key or encryption=none"
Just "none" -> return ()
Just _ -> error "encryption keys not yet supported"
-- bup init will create the repository.
-- (If the repository already exists, bup init again appears safe.)
showNote "bup init"
ok <- bup "init" buprepo []
unless ok $ error "bup init failed"
storeBupUUID u buprepo
-- The buprepo is stored in git config, as well as this repo's
-- persistant state, so it can vary between hosts.
gitConfigSpecialRemote u c "buprepo" buprepo
return $ M.delete "directory" c
bupParams :: String -> String -> [CommandParam] -> [CommandParam]
bupParams command buprepo params =
(Param command) : [Param "-r", Param buprepo] ++ params
bup :: String -> String -> [CommandParam] -> Annex Bool
bup command buprepo params = do
showProgress -- make way for bup output
liftIO $ boolSystem "bup" $ bupParams command buprepo params
store :: Git.Repo -> String -> Key -> Annex Bool
store r buprepo k = do
g <- Annex.gitRepo
let src = gitAnnexLocation g k
o <- getConfig r "bup-split-options" ""
let os = map Param $ words o
bup "split" buprepo $ os ++ [Param "-n", Param (show k), File src]
retrieve :: String -> Key -> FilePath -> Annex Bool
retrieve buprepo k f = do
let params = bupParams "join" buprepo [Param $ show k]
ret <- liftIO $ try $ do
-- pipe bup's stdout directly to file
tofile <- openFile f WriteMode
p <- runProcess "bup" (toCommand params)
Nothing Nothing Nothing (Just tofile) Nothing
r <- waitForProcess p
case r of
ExitSuccess -> return True
_ -> return False
case ret of
Right r -> return r
Left _ -> return False
remove :: Key -> Annex Bool
remove _ = do
warning "content cannot be removed from bup remote"
return False
{- Bup does not provide a way to tell if a given dataset is present
- in a bup repository. One way it to check if the git repository has
- a branch matching the name (as created by bup split -n).
-
- However, git-annex's ususal reasons for checking if a remote really
- has a key also don't really apply in the case of bup, since, short
- of deleting bup's git repository, data cannot be removed from it.
-
- So, trust git-annex's location log; if it says a bup repository has
- content, assume it's right.
-}
checkPresent :: UUID -> Key -> Annex (Either IOException Bool)
checkPresent u k = do
g <- Annex.gitRepo
liftIO $ try $ do
uuids <- keyLocations g k
return $ u `elem` uuids
{- Store UUID in the annex.uuid setting of the bup repository. -}
storeBupUUID :: UUID -> FilePath -> Annex ()
storeBupUUID u buprepo = do
r <- liftIO $ bup2GitRemote buprepo
if Git.repoIsUrl r
then do
showNote "storing uuid"
let dir = shellEscape (Git.workTree r)
sshparams <- sshToRepo r
[Param $ "cd " ++ dir ++
" && git config annex.uuid " ++ u]
ok <- liftIO $ boolSystem "ssh" sshparams
unless ok $ do error "ssh failed"
else liftIO $ do
r' <- Git.configRead r
let olduuid = Git.configGet r' "annex.uuid" ""
when (olduuid == "") $
Git.run r' "config" [Param "annex.uuid", Param u]
{- Allow for bup repositories on removable media by checking
- local bup repositories to see if they are available, and getting their
- uuid (which may be different from the stored uuid for the bup remote).
-
- If a bup repository is not available, returns a dummy uuid of "".
- This will cause checkPresent to indicate nothing from the bup remote
- is known to be present.
-}
getBupUUID :: FilePath -> UUID -> Annex UUID
getBupUUID buprepo u = liftIO $ do
r <- bup2GitRemote buprepo
if Git.repoIsUrl r
then return u
else do
ret <- try $ Git.configRead r
case ret of
Right r' -> return $ Git.configGet r' "annex.uuid" ""
Left _ -> return ""
{- Converts a bup remote path spec into a Git.Repo. There are some
- differences in path representation between git and bup. -}
bup2GitRemote :: FilePath -> IO Git.Repo
bup2GitRemote "" = do
-- bup -r "" operates on ~/.bup
h <- myHomeDir
Git.repoFromAbsPath $ h </> ".bup"
bup2GitRemote r
| bupLocal r =
if r !! 0 == '/'
then Git.repoFromAbsPath r
else error "please specify an absolute path"
| otherwise = Git.repoFromUrl $ "ssh://" ++ host ++ slash dir
where
bits = split ":" r
host = bits !! 0
dir = join ":" $ drop 1 bits
-- "host:~user/dir" is not supported specially by bup;
-- "host:dir" is relative to the home directory;
-- "host:" goes in ~/.bup
slash d
| d == "" = "/~/.bup"
| d !! 0 == '/' = d
| otherwise = "/~/" ++ d
bupLocal :: FilePath -> Bool
bupLocal = notElem ':'
|
