1{- Using bup as a remote.
2 -
3 - Copyright 2011-2020 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8{-# LANGUAGE RankNTypes #-}
9
10module Remote.Bup (remote) where
11
12import qualified Data.Map as M
13import qualified Data.ByteString as S
14import qualified Data.ByteString.Lazy as L
15import Data.ByteString.Lazy.UTF8 (fromString)
16
17import Annex.Common
18import qualified Annex
19import Types.Remote
20import Types.Creds
21import Git.Types (ConfigValue(..), fromConfigKey)
22import qualified Git
23import qualified Git.Command
24import qualified Git.Config
25import qualified Git.Construct
26import qualified Git.Ref
27import Config
28import Config.Cost
29import qualified Remote.Helper.Ssh as Ssh
30import Annex.SpecialRemote.Config
31import Remote.Helper.Special
32import Remote.Helper.ExportImport
33import Utility.Hash
34import Utility.UserInfo
35import Annex.UUID
36import Annex.Ssh
37import Utility.Metered
38import Types.ProposedAccepted
39
40type BupRepo = String
41
42remote :: RemoteType
43remote = specialRemoteType $ RemoteType
44	{ typename = "bup"
45	, enumerate = const (findSpecialRemotes "buprepo")
46	, generate = gen
47	, configParser = mkRemoteConfigParser
48		[ optionalStringParser buprepoField
49			(FieldDesc "(required) bup repository to use")
50		]
51	, setup = bupSetup
52	, exportSupported = exportUnsupported
53	, importSupported = importUnsupported
54	, thirdPartyPopulated = False
55	}
56
57buprepoField :: RemoteConfigField
58buprepoField = Accepted "buprepo"
59
60gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
61gen r u rc gc rs = do
62	c <- parsedRemoteConfig remote rc
63	bupr <- liftIO $ bup2GitRemote buprepo
64	cst <- remoteCost gc $
65		if bupLocal buprepo
66			then nearlyCheapRemoteCost
67			else expensiveRemoteCost
68	(u', bupr') <- getBupUUID bupr u
69
70	let this = Remote
71		{ uuid = u'
72		, cost = cst
73		, name = Git.repoDescribe r
74		, storeKey = storeKeyDummy
75		, retrieveKeyFile = retrieveKeyFileDummy
76		, retrieveKeyFileCheap = Nothing
77		-- Bup uses git, which cryptographically verifies content
78		-- (with SHA1, but sufficiently for this).
79		, retrievalSecurityPolicy = RetrievalAllKeysSecure
80		, removeKey = removeKeyDummy
81		, lockContent = Nothing
82		, checkPresent = checkPresentDummy
83		, checkPresentCheap = bupLocal buprepo
84		, exportActions = exportUnsupported
85		, importActions = importUnsupported
86		, whereisKey = Nothing
87		, remoteFsck = Nothing
88		, repairRepo = Nothing
89		, config = c
90		, getRepo = return r
91		, gitconfig = gc
92		, localpath = if bupLocal buprepo && not (null buprepo)
93			then Just buprepo
94			else Nothing
95		, remotetype = remote
96		, availability = if bupLocal buprepo then LocallyAvailable else GloballyAvailable
97		, readonly = False
98		, appendonly = False
99		, untrustworthy = False
100		, mkUnavailable = return Nothing
101		, getInfo = return [("repo", buprepo)]
102		, claimUrl = Nothing
103		, checkUrl = Nothing
104		, remoteStateHandle = rs
105		}
106	let specialcfg = (specialRemoteCfg c)
107		-- chunking would not improve bup
108		{ chunkConfig = NoChunks
109		}
110	return $ Just $ specialRemote' specialcfg c
111		(store this buprepo)
112		(retrieve buprepo)
113		(remove buprepo)
114		(checkKey bupr')
115		this
116  where
117	buprepo = fromMaybe (giveup "missing buprepo") $ remoteAnnexBupRepo gc
118
119bupSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
120bupSetup _ mu _ c gc = do
121	u <- maybe (liftIO genUUID) return mu
122
123	-- verify configuration is sane
124	let buprepo = maybe (giveup "Specify buprepo=") fromProposedAccepted $
125		M.lookup buprepoField c
126	(c', _encsetup) <- encryptionSetup c gc
127
128	-- bup init will create the repository.
129	-- (If the repository already exists, bup init again appears safe.)
130	showAction "bup init"
131	unlessM (bup "init" buprepo []) $ giveup "bup init failed"
132
133	storeBupUUID u buprepo
134
135	-- The buprepo is stored in git config, as well as this repo's
136	-- persistant state, so it can vary between hosts.
137	gitConfigSpecialRemote u c' [("buprepo", buprepo)]
138
139	return (c', u)
140
141bupParams :: String -> BupRepo -> [CommandParam] -> [CommandParam]
142bupParams command buprepo params =
143	Param command : [Param "-r", Param buprepo] ++ params
144
145bup :: String -> BupRepo -> [CommandParam] -> Annex Bool
146bup command buprepo params = do
147	showOutput -- make way for bup output
148	liftIO $ boolSystem "bup" $ bupParams command buprepo params
149
150bupSplitParams :: Remote -> BupRepo -> Key -> [CommandParam] -> [CommandParam]
151bupSplitParams r buprepo k src =
152	let os = map Param $ remoteAnnexBupSplitOptions $ gitconfig r
153	in bupParams "split" buprepo
154		(os ++ [Param "-q", Param "-n", Param (bupRef k)] ++ src)
155
156store :: Remote -> BupRepo -> Storer
157store r buprepo = byteStorer $ \k b p -> do
158	showOutput -- make way for bup output
159	quiet <- commandProgressDisabled
160	liftIO $ withNullHandle $ \nullh ->
161		let params = bupSplitParams r buprepo k []
162		    cmd = (proc "bup" (toCommand params))
163			{ std_in = CreatePipe }
164		    cmd' = if quiet
165			then cmd
166				{ std_out = UseHandle nullh
167				, std_err = UseHandle nullh
168				}
169			else cmd
170		    feeder = \h -> do
171			meteredWrite p (S.hPut h) b
172			hClose h
173		in withCreateProcess cmd' (go feeder cmd')
174  where
175	go feeder p (Just h) _ _ pid =
176		forceSuccessProcess p pid
177			`after`
178		feeder h
179	go _ _ _ _ _ _ = error "internal"
180
181retrieve :: BupRepo -> Retriever
182retrieve buprepo = byteRetriever $ \k sink -> do
183	let params = bupParams "join" buprepo [Param $ bupRef k]
184	let p = (proc "bup" (toCommand params))
185		{ std_out = CreatePipe }
186	bracketIO (createProcess p) cleanupProcess (go sink p)
187  where
188	go sink p (_, Just h, _, pid) = do
189		r <- sink =<< liftIO (L.hGetContents h)
190		liftIO $ do
191			hClose h
192			forceSuccessProcess p pid
193		return r
194	go _ _ _ = error "internal"
195
196{- Cannot revert having stored a key in bup, but at least the data for the
197 - key will be used for deltaing data of other keys stored later.
198 -
199 - We can, however, remove the git branch that bup created for the key.
200 -}
201remove :: BupRepo -> Remover
202remove buprepo k = do
203	go =<< liftIO (bup2GitRemote buprepo)
204	warning "content cannot be completely removed from bup remote"
205  where
206	go r
207		| Git.repoIsUrl r = void $ onBupRemote r boolSystem "git" params
208		| otherwise = void $ liftIO $ catchMaybeIO $ do
209			r' <- Git.Config.read r
210			boolSystem "git" $ Git.Command.gitCommandLine params r'
211	params = [ Param "branch", Param "-q", Param "-D", Param (bupRef k) ]
212
213{- Bup does not provide a way to tell if a given dataset is present
214 - in a bup repository. One way it to check if the git repository has
215 - a branch matching the name (as created by bup split -n).
216 -}
217checkKey :: Git.Repo -> CheckPresent
218checkKey bupr k
219	| Git.repoIsUrl bupr = onBupRemote bupr boolSystem "git" params
220	| otherwise = liftIO $ boolSystem "git" $
221		Git.Command.gitCommandLine params bupr
222  where
223	params =
224		[ Param "show-ref"
225		, Param "--quiet"
226		, Param "--verify"
227		, Param $ "refs/heads/" ++ bupRef k
228		]
229
230{- Store UUID in the annex.uuid setting of the bup repository. -}
231storeBupUUID :: UUID -> BupRepo -> Annex ()
232storeBupUUID u buprepo = do
233	r <- liftIO $ bup2GitRemote buprepo
234	if Git.repoIsUrl r
235		then do
236			showAction "storing uuid"
237			unlessM (onBupRemote r boolSystem "git"
238				[Param "config", Param (fromConfigKey configkeyUUID), Param v]) $
239					giveup "ssh failed"
240		else liftIO $ do
241			r' <- Git.Config.read r
242			let noolduuid = case Git.Config.get configkeyUUID mempty r' of
243				ConfigValue olduuid -> S.null olduuid
244				NoConfigValue -> True
245			when noolduuid $
246				Git.Command.run
247					[ Param "config"
248					, Param "annex.uuid"
249					, Param v
250					] r'
251  where
252	v = fromUUID u
253
254onBupRemote :: Git.Repo -> (FilePath -> [CommandParam] -> IO a) -> FilePath -> [CommandParam] -> Annex a
255onBupRemote r runner command params = do
256	c <- Annex.getRemoteGitConfig r
257	let remotecmd = "cd " ++ dir ++ " && " ++ unwords (command : toCommand params)
258	(sshcmd, sshparams) <- Ssh.toRepo NoConsumeStdin r c remotecmd
259	liftIO $ runner sshcmd sshparams
260  where
261	path = fromRawFilePath $ Git.repoPath r
262	base = fromMaybe path (stripPrefix "/~/" path)
263	dir = shellEscape base
264
265{- Allow for bup repositories on removable media by checking
266 - local bup repositories to see if they are available, and getting their
267 - uuid (which may be different from the stored uuid for the bup remote).
268 -
269 - If a bup repository is not available, returns NoUUID.
270 - This will cause checkPresent to indicate nothing from the bup remote
271 - is known to be present.
272 -
273 - Also, returns a version of the repo with config read, if it is local.
274 -}
275getBupUUID :: Git.Repo -> UUID -> Annex (UUID, Git.Repo)
276getBupUUID r u
277	| Git.repoIsUrl r = return (u, r)
278	| otherwise = liftIO $ do
279		ret <- tryIO $ Git.Config.read r
280		case ret of
281			Right r' -> return (toUUID $ Git.Config.get configkeyUUID mempty r', r')
282			Left _ -> return (NoUUID, r)
283
284{- Converts a bup remote path spec into a Git.Repo. There are some
285 - differences in path representation between git and bup. -}
286bup2GitRemote :: BupRepo -> IO Git.Repo
287bup2GitRemote "" = do
288	-- bup -r "" operates on ~/.bup
289	h <- myHomeDir
290	Git.Construct.fromPath $ toRawFilePath $ h </> ".bup"
291bup2GitRemote r
292	| bupLocal r =
293		if "/" `isPrefixOf` r
294			then Git.Construct.fromPath (toRawFilePath r)
295			else giveup "please specify an absolute path"
296	| otherwise = Git.Construct.fromUrl $ "ssh://" ++ host ++ slash dir
297  where
298	bits = splitc ':' r
299	host = Prelude.head bits
300	dir = intercalate ":" $ drop 1 bits
301	-- "host:~user/dir" is not supported specially by bup;
302	-- "host:dir" is relative to the home directory;
303	-- "host:" goes in ~/.bup
304	slash d
305		| null d = "/~/.bup"
306		| "/" `isPrefixOf` d = d
307		| otherwise = "/~/" ++ d
308
309{- Converts a key into a git ref name, which bup-split -n will use to point
310 - to it. -}
311bupRef :: Key -> String
312bupRef k
313	| Git.Ref.legal True shown = shown
314	| otherwise = "git-annex-" ++ show (sha2_256 (fromString shown))
315  where
316	shown = serializeKey k
317
318bupLocal :: BupRepo -> Bool
319bupLocal = notElem ':'
320