summaryrefslogtreecommitdiff
path: root/Remote/Bup.hs
blob: d2c3038affeec8746eb6878262c94d620a1f4840 (plain)
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
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
{- 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 qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
import System.Process
import Data.ByteString.Lazy.UTF8 (fromString)

import Common.Annex
import Types.Remote
import Types.Key
import qualified Git
import qualified Git.Command
import qualified Git.Config
import qualified Git.Construct
import qualified Git.Ref
import Config
import Config.Cost
import qualified Remote.Helper.Ssh as Ssh
import Remote.Helper.Special
import Remote.Helper.Encryptable
import Remote.Helper.Messages
import Crypto
import Utility.Hash
import Utility.UserInfo
import Annex.Content
import Annex.UUID
import Utility.Metered

type BupRepo = String

remote :: RemoteType
remote = RemoteType {
	typename = "bup",
	enumerate = findSpecialRemotes "buprepo",
	generate = gen,
	setup = bupSetup
}

gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen r u c gc = do
	bupr <- liftIO $ bup2GitRemote buprepo
	cst <- remoteCost gc $
		if bupLocal buprepo
			then nearlyCheapRemoteCost
			else expensiveRemoteCost
	(u', bupr') <- getBupUUID bupr u
	
	let new = Remote
		{ uuid = u'
		, cost = cst
		, name = Git.repoDescribe r
		, storeKey = store new buprepo
		, retrieveKeyFile = retrieve buprepo
		, retrieveKeyFileCheap = retrieveCheap buprepo
		, removeKey = remove
		, hasKey = checkPresent r bupr'
		, hasKeyCheap = bupLocal buprepo
		, whereisKey = Nothing
		, remoteFsck = Nothing
		, config = c
		, repo = r
		, gitconfig = gc
		, localpath = if bupLocal buprepo && not (null buprepo)
			then Just buprepo
			else Nothing
		, remotetype = remote
		, globallyAvailable = not $ bupLocal buprepo
		, readonly = False
		}
	return $ Just $ encryptableRemote c
		(storeEncrypted new buprepo)
		(retrieveEncrypted buprepo)
		new
  where
	buprepo = fromMaybe (error "missing buprepo") $ remoteAnnexBupRepo gc

bupSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
bupSetup mu c = do
	u <- maybe (liftIO genUUID) return mu

	-- verify configuration is sane
	let buprepo = fromMaybe (error "Specify buprepo=") $
		M.lookup "buprepo" c
	c' <- encryptionSetup c

	-- bup init will create the repository.
	-- (If the repository already exists, bup init again appears safe.)
	showAction "bup init"
	unlessM (bup "init" buprepo []) $ 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 (c', u)

bupParams :: String -> BupRepo -> [CommandParam] -> [CommandParam]
bupParams command buprepo params = 
	Param command : [Param "-r", Param buprepo] ++ params

bup :: String -> BupRepo -> [CommandParam] -> Annex Bool
bup command buprepo params = do
	showOutput -- make way for bup output
	liftIO $ boolSystem "bup" $ bupParams command buprepo params

pipeBup :: [CommandParam] -> Maybe Handle -> Maybe Handle -> IO Bool
pipeBup params inh outh = do
	p <- runProcess "bup" (toCommand params)
		Nothing Nothing inh outh Nothing
	ok <- waitForProcess p
	case ok of
		ExitSuccess -> return True
		_ -> return False

bupSplitParams :: Remote -> BupRepo -> Key -> [CommandParam] -> Annex [CommandParam]
bupSplitParams r buprepo k src = do
	let os = map Param $ remoteAnnexBupSplitOptions $ gitconfig r
	showOutput -- make way for bup output
	return $ bupParams "split" buprepo 
		(os ++ [Param "-n", Param (bupRef k)] ++ src)

store :: Remote -> BupRepo -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store r buprepo k _f _p = sendAnnex k (rollback k buprepo) $ \src -> do
	params <- bupSplitParams r buprepo k [File src]
	liftIO $ boolSystem "bup" params

storeEncrypted :: Remote -> BupRepo -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
storeEncrypted r buprepo (cipher, enck) k _p =
	sendAnnex k (rollback enck buprepo) $ \src -> do
		params <- bupSplitParams r buprepo enck []
		liftIO $ catchBoolIO $
			encrypt (getGpgEncParams r) cipher (feedFile src) $ \h ->
				pipeBup params (Just h) Nothing

retrieve :: BupRepo -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
retrieve buprepo k _f d _p = do
	let params = bupParams "join" buprepo [Param $ bupRef k]
	liftIO $ catchBoolIO $ do
		tofile <- openFile d WriteMode
		pipeBup params Nothing (Just tofile)

retrieveCheap :: BupRepo -> Key -> FilePath -> Annex Bool
retrieveCheap _ _ _ = return False

retrieveEncrypted :: BupRepo -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool
retrieveEncrypted buprepo (cipher, enck) _ f _p = liftIO $ catchBoolIO $
	withHandle StdoutHandle createProcessSuccess p $ \h -> do
		decrypt cipher (\toh -> L.hPut toh =<< L.hGetContents h) $
			readBytes $ L.writeFile f
		return True
  where
	params = bupParams "join" buprepo [Param $ bupRef enck]
	p = proc "bup" $ toCommand params

remove :: Key -> Annex Bool
remove _ = do
	warning "content cannot be removed from bup remote"
	return False

{- Cannot revert having stored a key in bup, but at least the data for the
 - key will be used for deltaing data of other keys stored later.
 -
 - We can, however, remove the git branch that bup created for the key.
 -}
rollback :: Key -> BupRepo -> Annex ()
rollback k bupr = go =<< liftIO (bup2GitRemote bupr)
  where
	go r
		| Git.repoIsUrl r = void $ onBupRemote r boolSystem "git" params
		| otherwise = void $ liftIO $ catchMaybeIO $
			boolSystem "git" $ Git.Command.gitCommandLine params r
	params = [ Params "branch -D", Param (bupRef k) ]

{- 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).
 -}
checkPresent :: Git.Repo -> Git.Repo -> Key -> Annex (Either String Bool)
checkPresent r bupr k
	| Git.repoIsUrl bupr = do
		showChecking r
		ok <- onBupRemote bupr boolSystem "git" params
		return $ Right ok
	| otherwise = liftIO $ catchMsgIO $
		boolSystem "git" $ Git.Command.gitCommandLine params bupr
  where
	params = 
		[ Params "show-ref --quiet --verify"
		, Param $ "refs/heads/" ++ bupRef k
		]

{- Store UUID in the annex.uuid setting of the bup repository. -}
storeBupUUID :: UUID -> BupRepo -> Annex ()
storeBupUUID u buprepo = do
	r <- liftIO $ bup2GitRemote buprepo
	if Git.repoIsUrl r
		then do
			showAction "storing uuid"
			unlessM (onBupRemote r boolSystem "git"
				[Params $ "config annex.uuid " ++ v]) $
					error "ssh failed"
		else liftIO $ do
			r' <- Git.Config.read r
			let olduuid = Git.Config.get "annex.uuid" "" r'
			when (olduuid == "") $
				Git.Command.run
					[ Param "config"
					, Param "annex.uuid"
					, Param v
					] r'
  where
	v = fromUUID u

onBupRemote :: Git.Repo -> (FilePath -> [CommandParam] -> IO a) -> FilePath -> [CommandParam] -> Annex a
onBupRemote r a command params = do
	sshparams <- Ssh.toRepo r [Param $
			"cd " ++ dir ++ " && " ++ unwords (command : toCommand params)]
	liftIO $ a "ssh" sshparams
  where
	path = Git.repoPath r
	base = fromMaybe path (stripPrefix "/~/" path)
	dir = shellEscape base

{- 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 NoUUID.
 - This will cause checkPresent to indicate nothing from the bup remote
 - is known to be present.
 -
 - Also, returns a version of the repo with config read, if it is local.
 -}
getBupUUID :: Git.Repo -> UUID -> Annex (UUID, Git.Repo)
getBupUUID r u
	| Git.repoIsUrl r = return (u, r)
	| otherwise = liftIO $ do
		ret <- tryIO $ Git.Config.read r
		case ret of
			Right r' -> return (toUUID $ Git.Config.get "annex.uuid" "" r', r')
			Left _ -> return (NoUUID, r)

{- Converts a bup remote path spec into a Git.Repo. There are some
 - differences in path representation between git and bup. -}
bup2GitRemote :: BupRepo -> IO Git.Repo
bup2GitRemote "" = do
	-- bup -r "" operates on ~/.bup
	h <- myHomeDir
	Git.Construct.fromAbsPath $ h </> ".bup"
bup2GitRemote r
	| bupLocal r = 
		if "/" `isPrefixOf` r
			then Git.Construct.fromAbsPath r
			else error "please specify an absolute path"
	| otherwise = Git.Construct.fromUrl $ "ssh://" ++ host ++ slash dir
  where
	bits = split ":" r
	host = Prelude.head bits
	dir = intercalate ":" $ 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
		| null d = "/~/.bup"
		| "/" `isPrefixOf` d = d
		| otherwise = "/~/" ++ d

{- Converts a key into a git ref name, which bup-split -n will use to point
 - to it. -}
bupRef :: Key -> String
bupRef k
	| Git.Ref.legal True shown = shown
	| otherwise = "git-annex-" ++ show (sha256 (fromString shown))
  where
	shown = key2file k

bupLocal :: BupRepo -> Bool
bupLocal = notElem ':'