summaryrefslogtreecommitdiff
path: root/Remote/Git.hs
blob: 6397c1a2e42624b46426651a69a23bb02bd5b106 (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
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
{- Standard git remotes.
 -
 - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Remote.Git (
	remote,
	configRead,
	repoAvail,
) where

import Common.Annex
import Annex.Ssh
import Types.Remote
import Types.GitConfig
import qualified Git
import qualified Git.Config
import qualified Git.Construct
import qualified Git.Command
import qualified Git.GCrypt
import qualified Git.Types as Git
import qualified Annex
import Logs.Presence
import Annex.Transfer
import Annex.UUID
import qualified Annex.Content
import qualified Annex.BranchState
import qualified Annex.Branch
import qualified Annex.Url as Url
import Utility.Tmp
import Config
import Config.Cost
import Annex.Init
import Types.Key
import Types.CleanupActions
import qualified CmdLine.GitAnnexShell.Fields as Fields
import Logs.Location
import Utility.Metered
#ifndef mingw32_HOST_OS
import Utility.CopyFile
#endif
import Utility.Env
import Utility.Batch
import Remote.Helper.Git
import Remote.Helper.Messages
import qualified Remote.Helper.Ssh as Ssh
import qualified Remote.GCrypt
import Config.Files
import Creds
import Annex.CatFile

import Control.Concurrent
import Control.Concurrent.MSampleVar
import qualified Data.Map as M
import Network.URI

remote :: RemoteType
remote = RemoteType {
	typename = "git",
	enumerate = list,
	generate = gen,
	setup = gitSetup
}

list :: Annex [Git.Repo]
list = do
	c <- fromRepo Git.config
	rs <- mapM (tweakurl c) =<< fromRepo Git.remotes
	mapM configRead rs
  where
	annexurl n = "remote." ++ n ++ ".annexurl"
	tweakurl c r = do
		let n = fromJust $ Git.remoteName r
		case M.lookup (annexurl n) c of
			Nothing -> return r
			Just url -> inRepo $ \g ->
				Git.Construct.remoteNamed n $
					Git.Construct.fromRemoteLocation url g

{- Git remotes are normally set up using standard git command, not
 - git-annex initremote and enableremote.
 -
 - For initremote, the git remote must already be set up, and have a uuid.
 - Initremote simply remembers its location.
 -
 - enableremote simply sets up a git remote using the stored location.
 - No attempt is made to make the remote be accessible via ssh key setup,
 - etc.
 -}
gitSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
gitSetup Nothing _ c = do
	let location = fromMaybe (error "Specify location=url") $
		Url.parseURIRelaxed =<< M.lookup "location" c
	g <- Annex.gitRepo
	u <- case filter (\r -> Git.location r == Git.Url location) (Git.remotes g) of
		[r] -> getRepoUUID r
		[] -> error "could not find existing git remote with specified location"
		_ -> error "found multiple git remotes with specified location"
	return (c, u)
gitSetup (Just u) _ c = do
	inRepo $ Git.Command.run
		[ Param "remote"
		, Param "add"
		, Param $ fromMaybe (error "no name") (M.lookup "name" c)
		, Param $ fromMaybe (error "no location") (M.lookup "location" c)
		]
	return (c, u)

{- It's assumed to be cheap to read the config of non-URL remotes, so this is
 - done each time git-annex is run in a way that uses remotes.
 -
 - Conversely, the config of an URL remote is only read when there is no
 - cached UUID value. -}
configRead :: Git.Repo -> Annex Git.Repo
configRead r = do
	gc <- Annex.getRemoteGitConfig r
	u <- getRepoUUID r
	case (repoCheap r, remoteAnnexIgnore gc, u) of
		(_, True, _) -> return r
		(True, _, _) -> tryGitConfigRead r
		(False, _, NoUUID) -> tryGitConfigRead r
		_ -> return r

gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen r u c gc
	| Git.GCrypt.isEncrypted r = Remote.GCrypt.chainGen r u c gc
	| otherwise = go <$> remoteCost gc defcst
  where
	defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost
	go cst = Just new
	  where
		new = Remote 
			{ uuid = u
			, cost = cst
			, name = Git.repoDescribe r
			, storeKey = copyToRemote new
			, retrieveKeyFile = copyFromRemote new
			, retrieveKeyFileCheap = copyFromRemoteCheap new
			, removeKey = dropKey new
			, checkPresent = inAnnex new
			, checkPresentCheap = repoCheap r
			, whereisKey = Nothing
			, remoteFsck = if Git.repoIsUrl r
				then Nothing
				else Just $ fsckOnRemote r
			, repairRepo = if Git.repoIsUrl r
				then Nothing
				else Just $ repairRemote r
			, config = c
			, localpath = localpathCalc r
			, repo = r
			, gitconfig = gc
				{ remoteGitConfig = Just $ extractGitConfig r }
			, readonly = Git.repoIsHttp r
			, availability = availabilityCalc r
			, remotetype = remote
			, mkUnavailable = unavailable r u c gc
			}

unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
unavailable r u c gc = gen r' u c gc
  where
	r' = case Git.location r of
		Git.Local { Git.gitdir = d } ->
			r { Git.location = Git.LocalUnknown d }
		Git.Url url -> case uriAuthority url of
			Just auth -> 
				let auth' = auth { uriRegName = "!dne!" }
				in r { Git.location = Git.Url (url { uriAuthority = Just auth' })}
			Nothing -> r { Git.location = Git.Unknown }
		_ -> r -- already unavailable

{- Checks relatively inexpensively if a repository is available for use. -}
repoAvail :: Git.Repo -> Annex Bool
repoAvail r 
	| Git.repoIsHttp r = return True
	| Git.GCrypt.isEncrypted r = do
		g <- gitRepo
		liftIO $ do
			er <- Git.GCrypt.encryptedRemote g r
			if Git.repoIsLocal er || Git.repoIsLocalUnknown er
				then catchBoolIO $
					void (Git.Config.read er) >> return True
				else return True
	| Git.repoIsUrl r = return True
	| Git.repoIsLocalUnknown r = return False
	| otherwise = liftIO $ isJust <$> catchMaybeIO (Git.Config.read r)

{- Tries to read the config for a specified remote, updates state, and
 - returns the updated repo. -}
tryGitConfigRead :: Git.Repo -> Annex Git.Repo
tryGitConfigRead r 
	| haveconfig r = return r -- already read
	| Git.repoIsSsh r = store $ do
		v <- Ssh.onRemote r (pipedconfig, return (Left undefined)) "configlist" [] []
		case v of
			Right r'
				| haveconfig r' -> return r'
				| otherwise -> configlist_failed
			Left _ -> configlist_failed
	| Git.repoIsHttp r = store geturlconfig
	| Git.GCrypt.isEncrypted r = handlegcrypt =<< getConfigMaybe (remoteConfig r "uuid")
	| Git.repoIsUrl r = return r
	| otherwise = store $ liftIO $ 
		readlocalannexconfig `catchNonAsync` (const $ return r)
  where
	haveconfig = not . M.null . Git.config

	pipedconfig cmd params = do
		v <- Git.Config.fromPipe r cmd params
		case v of
			Right (r', val) -> do
				when (getUncachedUUID r' == NoUUID && not (null val)) $ do
					warningIO $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r
					warningIO $ "Instead, got: " ++ show val
					warningIO $ "This is unexpected; please check the network transport!"
				return $ Right r'
			Left l -> return $ Left l

	geturlconfig = do
		uo <- Url.getUrlOptions
		v <- liftIO $ withTmpFile "git-annex.tmp" $ \tmpfile h -> do
			hClose h
			ifM (Url.downloadQuiet (Git.repoLocation r ++ "/config") tmpfile uo)
				( pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile]
				, return $ Left undefined
				)
		case v of
			Left _ -> do
				set_ignore "not usable by git-annex" False
				return r
			Right r' -> do
				-- Cache when http remote is not bare for
				-- optimisation.
				unless (Git.Config.isBare r') $
					setremote "annex-bare" (Git.Config.boolConfig False)
				return r'

	store = observe $ \r' -> do
		g <- gitRepo
		let l = Git.remotes g
		let g' = g { Git.remotes = exchange l r' }
		Annex.changeState $ \s -> s { Annex.repo = g' }

	exchange [] _ = []
	exchange (old:ls) new
		| Git.remoteName old == Git.remoteName new =
			new : exchange ls new
		| otherwise =
			old : exchange ls new

	{- Is this remote just not available, or does
	 - it not have git-annex-shell?
	 - Find out by trying to fetch from the remote. -}
	configlist_failed = case Git.remoteName r of
		Nothing -> return r
		Just n -> do
			whenM (inRepo $ Git.Command.runBool [Param "fetch", Param "--quiet", Param n]) $ do
				set_ignore "does not have git-annex installed" True
			return r
	
	set_ignore msg longmessage = do
		let k = "annex-ignore"
		case Git.remoteName r of
			Nothing -> noop
			Just n -> do
				warning $ "Remote " ++ n ++ " " ++ msg ++ "; setting " ++ k
				when longmessage $
					warning $ "This could be a problem with the git-annex installation on the remote. Please make sure that git-annex-shell is available in PATH when you ssh into the remote. Once you have fixed the git-annex installation, run: git config remote." ++ n ++ "." ++ k ++ " false"
		setremote k (Git.Config.boolConfig True)
	
	setremote k v = case Git.remoteName r of
		Nothing -> noop
		Just n -> do
			let k' = "remote." ++ n ++ "." ++ k
			inRepo $ Git.Command.run [Param "config", Param k', Param v]
		
	handlegcrypt Nothing = return r
	handlegcrypt (Just _cacheduuid) = do
		-- Generate UUID from the gcrypt-id
		g <- gitRepo
		case Git.GCrypt.remoteRepoId g (Git.remoteName r) of
			Nothing -> return r
			Just v -> store $ liftIO $ setUUID r $
				genUUIDInNameSpace gCryptNameSpace v

	{- The local repo may not yet be initialized, so try to initialize
	 - it if allowed. However, if that fails, still return the read
	 - git config. -}
	readlocalannexconfig = do
		s <- Annex.new r
		Annex.eval s $ do
			Annex.BranchState.disableUpdate
			void $ tryNonAsync $ ensureInitialized
			Annex.getState Annex.repo

{- Checks if a given remote has the content for a key in its annex. -}
inAnnex :: Remote -> Key -> Annex Bool
inAnnex rmt key
	| Git.repoIsHttp r = checkhttp
	| Git.repoIsUrl r = checkremote
	| otherwise = checklocal
  where
  	r = repo rmt
	checkhttp = do
		showChecking r
		ifM (Url.withUrlOptions $ \uo -> anyM (\u -> Url.checkBoth u (keySize key) uo) (keyUrls rmt key))
			( return True
			, error "not found"
			)
	checkremote = Ssh.inAnnex r key
	checklocal = guardUsable r (cantCheck r) $
		maybe (cantCheck r) return
			=<< onLocal rmt (Annex.Content.inAnnexSafe key)

keyUrls :: Remote -> Key -> [String]
keyUrls r key = map tourl locs'
  where
	tourl l = Git.repoLocation (repo r) ++ "/" ++ l
	-- If the remote is known to not be bare, try the hash locations
	-- used for non-bare repos first, as an optimisation.
	locs
		| remoteAnnexBare (gitconfig r) == Just False = reverse (annexLocations key)
		| otherwise = annexLocations key
#ifndef mingw32_HOST_OS
	locs' = locs
#else
	locs' = map (replace "\\" "/") locs
#endif

dropKey :: Remote -> Key -> Annex Bool
dropKey r key
	| not $ Git.repoIsUrl (repo r) =
		guardUsable (repo r) (return False) $
			commitOnCleanup r $ onLocal r $ do
				ensureInitialized
				whenM (Annex.Content.inAnnex key) $ do
					Annex.Content.lockContent key
						Annex.Content.removeAnnex
					logStatus key InfoMissing
					Annex.Content.saveState True
				return True
	| Git.repoIsHttp (repo r) = error "dropping from http remote not supported"
	| otherwise = commitOnCleanup r $ Ssh.dropKey (repo r) key

{- Tries to copy a key's content from a remote's annex to a file. -}
copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
copyFromRemote r key file dest _p = copyFromRemote' r key file dest
copyFromRemote' :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
copyFromRemote' r key file dest
	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $ do
		params <- Ssh.rsyncParams r Download
		u <- getUUID
		hardlink <- annexHardLink <$> Annex.getGitConfig
		-- run copy from perspective of remote
		onLocal r $ do
			ensureInitialized
			v <- Annex.Content.prepSendAnnex key
			case v of
				Nothing -> return False
				Just (object, checksuccess) -> do
					let copier = rsyncOrCopyFile params object dest
#ifndef mingw32_HOST_OS
					let linker = createLink object dest >> return True
					go <- ifM (pure hardlink <&&> not <$> isDirect)
						( return $ \m -> liftIO (catchBoolIO linker)
							<||> copier m
						, return copier
						)
#else
					let go = copier
#endif
					runTransfer (Transfer Download u key)
						file noRetry go
						<&&> checksuccess
	| Git.repoIsSsh (repo r) = feedprogressback $ \feeder -> do
		direct <- isDirect
		Ssh.rsyncHelper (Just feeder) 
			=<< Ssh.rsyncParamsRemote direct r Download key dest file
	| Git.repoIsHttp (repo r) = Annex.Content.downloadUrl (keyUrls r key) dest
	| otherwise = error "copying from non-ssh, non-http remote not supported"
  where
	{- Feed local rsync's progress info back to the remote,
	 - by forking a feeder thread that runs
	 - git-annex-shell transferinfo at the same time
	 - git-annex-shell sendkey is running.
	 -
	 - To avoid extra password prompts, this is only done when ssh
	 - connection caching is supported.
	 - Note that it actually waits for rsync to indicate
	 - progress before starting transferinfo, in order
	 - to ensure ssh connection caching works and reuses 
	 - the connection set up for the sendkey.
	 -
	 - Also note that older git-annex-shell does not support
	 - transferinfo, so stderr is dropped and failure ignored.
	 -}
	feedprogressback a = ifM (isJust <$> sshCacheDir)
		( feedprogressback' a
		, a $ const noop
		)
	feedprogressback' a = do
		u <- getUUID
		let fields = (Fields.remoteUUID, fromUUID u)
			: maybe [] (\f -> [(Fields.associatedFile, f)]) file
		Just (cmd, params) <- Ssh.git_annex_shell (repo r) "transferinfo" 
			[Param $ key2file key] fields
		v <- liftIO (newEmptySV :: IO (MSampleVar Integer))
		pidv <- liftIO $ newEmptyMVar
		tid <- liftIO $ forkIO $ void $ tryIO $ do
			bytes <- readSV v
			p <- createProcess $
				 (proc cmd (toCommand params))
					{ std_in = CreatePipe
					, std_err = CreatePipe
					}
			putMVar pidv (processHandle p)
			hClose $ stderrHandle p
			let h = stdinHandle p
			let send b = do
				hPrint h b
				hFlush h
			send bytes
			forever $
				send =<< readSV v
		let feeder = writeSV v . fromBytesProcessed
		let cleanup = do
			void $ tryIO $ killThread tid
			tryNonAsync $
				maybe noop (void . waitForProcess)
					=<< tryTakeMVar pidv
		bracketIO noop (const cleanup) (const $ a feeder)

copyFromRemoteCheap :: Remote -> Key -> FilePath -> Annex Bool
#ifndef mingw32_HOST_OS
copyFromRemoteCheap r key file
	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $ do
		loc <- liftIO $ gitAnnexLocation key (repo r) $
			fromJust $ remoteGitConfig $ gitconfig r
		liftIO $ catchBoolIO $ createSymbolicLink loc file >> return True
	| Git.repoIsSsh (repo r) =
		ifM (Annex.Content.preseedTmp key file)
			( copyFromRemote' r key Nothing file
			, return False
			)
	| otherwise = return False
#else
copyFromRemoteCheap _ _ _ = return False
#endif

{- Tries to copy a key's content to a remote's annex. -}
copyToRemote :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
copyToRemote r key file p
	| not $ Git.repoIsUrl (repo r) =
		guardUsable (repo r) (return False) $ commitOnCleanup r $
			copylocal =<< Annex.Content.prepSendAnnex key
	| Git.repoIsSsh (repo r) = commitOnCleanup r $
		Annex.Content.sendAnnex key noop $ \object -> do
			direct <- isDirect
			Ssh.rsyncHelper (Just p)
				=<< Ssh.rsyncParamsRemote direct r Upload key object file
	| otherwise = error "copying to non-ssh repo not supported"
  where
	copylocal Nothing = return False
	copylocal (Just (object, checksuccess)) = do
		-- The checksuccess action is going to be run in
		-- the remote's Annex, but it needs access to the current
		-- Annex monad's state.
		checksuccessio <- Annex.withCurrentState checksuccess
		params <- Ssh.rsyncParams r Upload
		u <- getUUID
		-- run copy from perspective of remote
		onLocal r $ ifM (Annex.Content.inAnnex key)
			( return True
			, do
				ensureInitialized
				runTransfer (Transfer Download u key) file noRetry $ const $
					Annex.Content.saveState True `after`
						Annex.Content.getViaTmpChecked (liftIO checksuccessio) key
							(\d -> rsyncOrCopyFile params object d p)
			)

fsckOnRemote :: Git.Repo -> [CommandParam] -> Annex (IO Bool)
fsckOnRemote r params
	| Git.repoIsUrl r = do
		s <- Ssh.git_annex_shell r "fsck" params []
		return $ case s of
			Nothing -> return False
			Just (c, ps) -> batchCommand c ps
	| otherwise = return $ do
		program <- readProgramFile
		r' <- Git.Config.read r
		environ <- getEnvironment
		let environ' = addEntries 
			[ ("GIT_WORK_TREE", Git.repoPath r')
			, ("GIT_DIR", Git.localGitDir r')
			] environ
		batchCommandEnv program (Param "fsck" : params) $ Just environ'

{- The passed repair action is run in the Annex monad of the remote. -}
repairRemote :: Git.Repo -> Annex Bool -> Annex (IO Bool)
repairRemote r a = return $ do
	s <- Annex.new r
	Annex.eval s $ do
		Annex.BranchState.disableUpdate
		ensureInitialized
		a

{- Runs an action from the perspective of a local remote.
 -
 - The AnnexState is cached for speed and to avoid resource leaks.
 - However, catFileStop is called to avoid git-cat-file processes hanging
 - around on removable media.
 -
 - The repository's git-annex branch is not updated, as an optimisation.
 - No caller of onLocal can query data from the branch and be ensured
 - it gets a current value. Caller of onLocal can make changes to
 - the branch, however.
 -}
onLocal :: Remote -> Annex a -> Annex a
onLocal r a = do
	m <- Annex.getState Annex.remoteannexstate
	case M.lookup (uuid r) m of
		Nothing -> do
			st <- liftIO $ Annex.new (repo r)
			go st $ do
				Annex.BranchState.disableUpdate	
				a
		Just st -> go st a
  where
	cache st = Annex.changeState $ \s -> s
		{ Annex.remoteannexstate = M.insert (uuid r) st (Annex.remoteannexstate s) }
	go st a' = do
		(ret, st') <- liftIO $ Annex.run st $
			catFileStop `after` a'
		cache st'
		return ret

{- Copys a file with rsync unless both locations are on the same
 - filesystem. Then cp could be faster. -}
rsyncOrCopyFile :: [CommandParam] -> FilePath -> FilePath -> MeterUpdate -> Annex Bool
rsyncOrCopyFile rsyncparams src dest p =
#ifdef mingw32_HOST_OS
	dorsync
  where
#else
	ifM (sameDeviceIds src dest) (docopy, dorsync)
  where
	sameDeviceIds a b = (==) <$> getDeviceId a <*> getDeviceId b
	getDeviceId f = deviceID <$> liftIO (getFileStatus $ parentDir f)
	docopy = liftIO $ bracket
		(forkIO $ watchfilesize zeroBytesProcessed)
		(void . tryIO . killThread)
		(const $ copyFileExternal CopyTimeStamps src dest)
	watchfilesize oldsz = do
		threadDelay 500000 -- 0.5 seconds
		v <- catchMaybeIO $
			toBytesProcessed . fileSize
				<$> getFileStatus dest
		case v of
			Just sz
				| sz /= oldsz -> do
					p sz
					watchfilesize sz
			_ -> watchfilesize oldsz
#endif
	dorsync = Ssh.rsyncHelper (Just p) $
		rsyncparams ++ [File src, File dest]

commitOnCleanup :: Remote -> Annex a -> Annex a
commitOnCleanup r a = go `after` a
  where
	go = Annex.addCleanup (RemoteCleanup $ uuid r) cleanup
	cleanup
		| not $ Git.repoIsUrl (repo r) = onLocal r $
			doQuietSideAction $
				Annex.Branch.commit "update"
		| otherwise = void $ do
			Just (shellcmd, shellparams) <-
				Ssh.git_annex_shell (repo r) "commit" [] []
			
			-- Throw away stderr, since the remote may not
			-- have a new enough git-annex shell to
			-- support committing.
			liftIO $ catchMaybeIO $
				withQuietOutput createProcessSuccess $
					proc shellcmd $
						toCommand shellparams