git-annex-shell: Added support for operating inside gcrypt repositories.

* Note that the layout of gcrypt repositories has changed, and
  if you created one you must manually upgrade it.
  See http://git-annex.branchable.com/upgrades/gcrypt/

Assistant/WebApp/Configurators/Local.hs

@@ -495,6 +495,4 @@ probeUUID dir = catchDefaultIO Nothing $ inDir dir $ do
  - Only works if the gcrypt repo was created as a git-annex remote. -}
 probeGCryptRemoteUUID :: FilePath -> IO (Maybe UUID)
 probeGCryptRemoteUUID dir = catchDefaultIO Nothing $ do
-	r <- Git.Construct.fromAbsPath dir
-	(genUUIDInNameSpace gCryptNameSpace <$>) . fst
-		<$> GCrypt.getGCryptId r
+	GCrypt.getGCryptUUID =<< Git.Construct.fromAbsPath dir

Command/ConfigList.hs

@@ -10,6 +10,8 @@ module Command.ConfigList where
 import Common.Annex
 import Command
 import Annex.UUID
+import qualified Git.Config
+import Remote.GCrypt (coreGCryptId)
 
 def :: [Command]
 def = [noCommit $ command "configlist" paramNothing seek
@@ -21,5 +23,8 @@ seek = [withNothing start]
 start :: CommandStart
 start = do
 	u <- getUUID
-	liftIO $ putStrLn $ "annex.uuid=" ++ fromUUID u
+	showConfig "annex.uuid" $ fromUUID u
+	showConfig coreGCryptId =<< fromRepo (Git.Config.get coreGCryptId "")
 	stop
+  where
+  	showConfig k v = liftIO $ putStrLn $ k ++ "=" ++ v

GitAnnexShell.hs

@@ -19,6 +19,9 @@ import Annex (setField)
 import qualified Option
 import Fields
 import Utility.UserInfo
+import Remote.GCrypt (getGCryptUUID)
+import qualified Annex
+import Init
 
 import qualified Command.ConfigList
 import qualified Command.InAnnex
@@ -44,23 +47,28 @@ cmds_notreadonly = concat
 	]
 
 cmds :: [Command]
-cmds = map adddirparam $ cmds_readonly ++ cmds_notreadonly
+cmds = map gitAnnexShellCheck $ map adddirparam $ cmds_readonly ++ cmds_notreadonly
   where
 	adddirparam c = c { cmdparamdesc = "DIRECTORY " ++ cmdparamdesc c }
 
 options :: [OptDescr (Annex ())]
 options = Option.common ++
-	[ Option [] ["uuid"] (ReqArg checkuuid paramUUID) "local repository uuid"
+	[ Option [] ["uuid"] (ReqArg checkUUID paramUUID) "local repository uuid"
 	]
   where
-	checkuuid expected = getUUID >>= check
+	checkUUID expected = getUUID >>= check
 	  where
 		check u | u == toUUID expected = noop
-		check NoUUID = unexpected "uninitialized repository"
-		check u = unexpected $ "UUID " ++ fromUUID u
-		unexpected s = error $
-			"expected repository UUID " ++
-			expected ++ " but found " ++ s
+		check NoUUID = checkGCryptUUID expected
+		check u = unexpectedUUID expected u
+	checkGCryptUUID expected = inRepo getGCryptUUID >>= check
+	  where
+	  	check (Just u) | u == toUUID expected = noop
+		check Nothing = unexpected expected "uninitialized repository"
+		check (Just u) = unexpectedUUID expected u
+	unexpectedUUID expected u = unexpected expected $ "UUID " ++ fromUUID u
+	unexpected expected s = error $
+		"expected repository UUID " ++ expected ++ " but found " ++ s
 
 header :: String
 header = "git-annex-shell [-c] command [parameters ...] [option ...]"
@@ -180,3 +188,11 @@ checkEnv var = do
 		Nothing -> noop
 		Just "" -> noop
 		Just _ -> error $ "Action blocked by " ++ var
+
+{- Modifies a Command to check that it is run in either a git-annex
+ - repository, or a repository with a gcrypt-id set. -}
+gitAnnexShellCheck :: Command -> Command
+gitAnnexShellCheck = addCheck okforshell . dontCheck repoExists
+  where
+	okforshell = unlessM (isInitialized <||> isJust . gcryptId <$> Annex.getGitConfig) $
+		error "Not a git-annex or gcrypt repository."

Locations.hs

@@ -10,6 +10,7 @@ module Locations (
 	fileKey,
 	keyPaths,
 	keyPath,
+	objectDir,
 	gitAnnexLocation,
 	gitAnnexLink,
 	gitAnnexMapping,

Remote/GCrypt.hs

@@ -5,7 +5,12 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module Remote.GCrypt (remote, gen, getGCryptId) where
+module Remote.GCrypt (
+	remote,
+	gen,
+	getGCryptUUID,
+	coreGCryptId
+) where
 
 import qualified Data.Map as M
 import qualified Data.ByteString.Lazy as L
@@ -27,6 +32,8 @@ import Config.Cost
 import Remote.Helper.Git
 import Remote.Helper.Encryptable
 import Remote.Helper.Special
+import Remote.Helper.Messages
+import qualified Remote.Helper.Ssh as Ssh
 import Utility.Metered
 import Crypto
 import Annex.UUID
@@ -34,7 +41,9 @@ import Annex.Ssh
 import qualified Remote.Rsync
 import Utility.Rsync
 import Logs.Remote
+import Logs.Transfer
 import Utility.Gpg
+import Annex.Content
 
 remote :: RemoteType
 remote = RemoteType {
@@ -78,22 +87,29 @@ gen gcryptr u c gc = do
 				warning $ "not using unknown gcrypt repository pointed to by remote " ++ Git.repoDescribe r
 				return Nothing
 
+getGCryptUUID :: Git.Repo -> IO (Maybe UUID)
+getGCryptUUID r = (genUUIDInNameSpace gCryptNameSpace <$>) . fst
+	<$> getGCryptId r
+
+coreGCryptId :: String
+coreGCryptId = "core.gcrypt-id"
+
 {- gcrypt repos set up by git-annex as special remotes have a
  - core.gcrypt-id setting in their config, which can be mapped back to
  - the remote's UUID. This only works for local repos.
  - (Also returns a version of input repo with its config read.) -}
 getGCryptId :: Git.Repo -> IO (Maybe Git.GCrypt.GCryptId, Git.Repo)
 getGCryptId r
-	| Git.repoIsLocalUnknown r = do
+	| Git.repoIsLocal r = do
 		r' <- catchDefaultIO r $ Git.Config.read r
-		return (Git.Config.getMaybe "core.gcrypt-id" r', r')
+		return (Git.Config.getMaybe coreGCryptId r', r')
 	| otherwise = return (Nothing, r)
 
 gen' :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen' r u c gc = do
 	cst <- remoteCost gc $
 		if repoCheap r then nearlyCheapRemoteCost else expensiveRemoteCost
-	(rsynctransport, rsyncurl) <- rsyncTransport r
+	(rsynctransport, rsyncurl) <- rsyncTransportToObjects r
 	let rsyncopts = Remote.Rsync.genRsyncOpts c gc rsynctransport rsyncurl
 	let this = Remote 
 		{ uuid = u
@@ -119,7 +135,12 @@ gen' r u c gc = do
 		(retrieve this rsyncopts)
 		this
 
-rsyncTransport :: Git.Repo -> Annex ([CommandParam], String)
+rsyncTransportToObjects :: Git.Repo -> Annex ([CommandParam], String)
+rsyncTransportToObjects r = do
+	(rsynctransport, rsyncurl, _) <- rsyncTransport r
+	return (rsynctransport, rsyncurl ++ "/annex/objects")
+
+rsyncTransport :: Git.Repo -> Annex ([CommandParam], String, AccessMethod)
 rsyncTransport r
 	| "ssh://" `isPrefixOf` loc = sshtransport $ break (== '/') $ drop (length "ssh://") loc
 	| "//:" `isInfixOf` loc = othertransport
@@ -129,8 +150,8 @@ rsyncTransport r
   	loc = Git.repoLocation r
 	sshtransport (host, path) = do
 		opts <- sshCachingOptions (host, Nothing) []
-		return (rsyncShell $ Param "ssh" : opts, host ++ ":" ++ path)
-	othertransport = return ([], loc)
+		return (rsyncShell $ Param "ssh" : opts, host ++ ":" ++ path, AccessShell)
+	othertransport = return ([], loc, AccessDirect)
 
 noCrypto :: Annex a
 noCrypto = error "cannot use gcrypt remote without encryption enabled"
@@ -174,17 +195,64 @@ gCryptSetup mu c = go $ M.lookup "gitrepo" c
 				let u = genUUIDInNameSpace gCryptNameSpace gcryptid
 				if Just u == mu || mu == Nothing
 					then do
-						-- Store gcrypt-id in local
-						-- gcrypt repository, for later
-						-- double-check.
-						r <- inRepo $ Git.Construct.fromRemoteLocation gitrepo
-						when (Git.repoIsLocalUnknown r) $ do
-							r' <- liftIO $ Git.Config.read r
-							liftIO $ Git.Command.run [Param "config", Param "core.gcrypt-id", Param gcryptid] r'
-						gitConfigSpecialRemote u c' "gcrypt" "true"
+						method <- setupRepo gcryptid =<< inRepo (Git.Construct.fromRemoteLocation gitrepo)
+						gitConfigSpecialRemote u c' "gcrypt" (fromAccessMethod method)
 						return (c', u)
 					else error "uuid mismatch"
 
+{- Sets up the gcrypt repository. The repository is either a local
+ - repo, or it is accessed via rsync directly, or it is accessed over ssh
+ - and git-annex-shell is available to manage it.
+ -
+ - The gcrypt-id is stored in the gcrypt repository for later
+ - double-checking and identification. This is always done using rsync.
+ -}
+setupRepo :: Git.GCrypt.GCryptId -> Git.Repo -> Annex AccessMethod
+setupRepo gcryptid r
+	| Git.repoIsUrl r = rsyncsetup
+	| Git.repoIsLocalUnknown r = localsetup =<< liftIO (Git.Config.read r)
+	| otherwise = localsetup r
+  where
+	localsetup r' = do
+		liftIO $ Git.Command.run [Param "config", Param coreGCryptId, Param gcryptid] r'
+		return AccessDirect
+
+	{- Download any git config file from the remote,
+	 - add the gcryptid to it, and send it back.
+	 -
+	 - At the same time, create the objectDir on the remote,
+	 - which is needed for direct rsync to work.
+	 -}
+  	rsyncsetup = Remote.Rsync.withRsyncScratchDir $ \tmp -> do
+		liftIO $ createDirectoryIfMissing True $ tmp </> objectDir
+		(rsynctransport, rsyncurl, accessmethod) <- rsyncTransport r
+		let tmpconfig = tmp </> "config"
+		void $ liftIO $ rsync $ rsynctransport ++
+			[ Param $ rsyncurl ++ "/config"
+			, Param tmpconfig
+			]
+		liftIO $ appendFile tmpconfig $ unlines
+			[ ""
+			, "[core]"
+			, "\tgcrypt-id = " ++ gcryptid
+			]
+		ok <- liftIO $ rsync $ rsynctransport ++
+			[ Params "--recursive"
+			, Param $ tmp ++ "/"
+			, Param $ rsyncurl
+			]
+		unless ok $
+			error "Failed to connect to remote to set it up."
+		return accessmethod
+
+shellOrRsync :: Remote -> Annex a -> Annex a -> Annex a
+shellOrRsync r ashell arsync = case method of
+	AccessShell -> ashell
+	_ -> arsync
+  where
+  	method = toAccessMethod $ fromMaybe "" $
+		remoteAnnexGCrypt $ gitconfig r
+
 {- Configure gcrypt to use the same list of keyids that
  - were passed to initremote as its participants.
  - Also, configure it to use a signing key that is in the list of
@@ -210,26 +278,32 @@ setGcryptEncryption c remotename = do
 store :: Remote -> Remote.Rsync.RsyncOpts -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
 store r rsyncopts (cipher, enck) k p
 	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $
-		sendwith $ \meterupdate h -> do
+		metered (Just p) k $ \meterupdate -> spoolencrypted $ \h -> do
+			let dest = gCryptLocation r enck
 			createDirectoryIfMissing True $ parentDir dest
 			readBytes (meteredWriteFile meterupdate dest) h
 			return True
-	| Git.repoIsSsh (repo r) = Remote.Rsync.storeEncrypted rsyncopts gpgopts (cipher, enck) k p
+	| Git.repoIsSsh (repo r) = shellOrRsync r storeshell storersync
 	| otherwise = unsupportedUrl
   where
   	gpgopts = getGpgEncParams r
-	dest = gCryptLocation r enck
-  	sendwith a = metered (Just p) k $ \meterupdate ->
-		Annex.Content.sendAnnex k noop $ \src ->
-			liftIO $ catchBoolIO $
-				encrypt gpgopts cipher (feedFile src) (a meterupdate)
+	storersync = Remote.Rsync.storeEncrypted rsyncopts gpgopts (cipher, enck) k p
+	storeshell = withTmp enck $ \tmp ->
+		ifM (spoolencrypted $ readBytes $ \b -> catchBoolIO $ L.writeFile tmp b >> return True)
+			( Ssh.rsyncHelper (Just p)
+				=<< Ssh.rsyncParamsRemote r Upload enck tmp Nothing
+			, return False
+			)
+	spoolencrypted a = Annex.Content.sendAnnex k noop $ \src ->
+		liftIO $ catchBoolIO $
+			encrypt gpgopts cipher (feedFile src) a
 
 retrieve :: Remote -> Remote.Rsync.RsyncOpts -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool
 retrieve r rsyncopts (cipher, enck) k d p
 	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do
 		retrievewith $ L.readFile src
 		return True
-	| Git.repoIsSsh (repo r) = Remote.Rsync.retrieveEncrypted rsyncopts (cipher, enck) k d p
+	| Git.repoIsSsh (repo r) = shellOrRsync r retrieveshell retrieversync
 	| otherwise = unsupportedUrl
   where
 	src = gCryptLocation r enck
@@ -237,30 +311,51 @@ retrieve r rsyncopts (cipher, enck) k d p
 		a >>= \b -> 
 			decrypt cipher (feedBytes b)
 				(readBytes $ meteredWriteFile meterupdate d)
+	retrieversync = Remote.Rsync.retrieveEncrypted rsyncopts (cipher, enck) k d p
+	retrieveshell = withTmp enck $ \tmp ->
+		ifM (Ssh.rsyncHelper (Just p) =<< Ssh.rsyncParamsRemote r Download enck tmp Nothing)
+			( liftIO $ catchBoolIO $ do
+				decrypt cipher (feedFile tmp) $
+					readBytes $ L.writeFile d
+				return True
+			, return False
+			)
 
 remove :: Remote -> Remote.Rsync.RsyncOpts -> Key -> Annex Bool
 remove r rsyncopts k
 	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do
-		liftIO $ removeDirectoryRecursive (parentDir dest)
+		liftIO $ removeDirectoryRecursive $ parentDir $ gCryptLocation r k
 		return True
-	| Git.repoIsSsh (repo r) = Remote.Rsync.remove rsyncopts k
+	| Git.repoIsSsh (repo r) = shellOrRsync r removeshell removersync
 	| otherwise = unsupportedUrl
   where
-	dest = gCryptLocation r k
+	removersync = Remote.Rsync.remove rsyncopts k
+	removeshell = Ssh.dropKey (repo r) k
 
 checkPresent :: Remote -> Remote.Rsync.RsyncOpts -> Key -> Annex (Either String Bool)
 checkPresent r rsyncopts k
 	| not $ Git.repoIsUrl (repo r) =
-		guardUsable (repo r) unknown $
-			liftIO $ catchDefaultIO unknown $
+		guardUsable (repo r) (cantCheck $ repo r) $
+			liftIO $ catchDefaultIO (cantCheck $ repo r) $
 				Right <$> doesFileExist (gCryptLocation r k)
-	| Git.repoIsSsh (repo r) = Remote.Rsync.checkPresent (repo r) rsyncopts k
+	| Git.repoIsSsh (repo r) = shellOrRsync r checkshell checkrsync
 	| otherwise = unsupportedUrl
   where
-	unknown = Left $ "unable to check " ++ Git.repoDescribe (repo r) ++ show (repo r)
+  	checkrsync = Remote.Rsync.checkPresent (repo r) rsyncopts k
+	checkshell = Ssh.inAnnex (repo r) k
 
-{- Annexed objects are stored directly under the top of the gcrypt repo
- - (not in annex/objects), and are hashed using lower-case directories for max
+{- Annexed objects are hashed using lower-case directories for max
  - portability. -}
 gCryptLocation :: Remote -> Key -> FilePath
-gCryptLocation r key = Git.repoLocation (repo r) </> keyPath key hashDirLower
+gCryptLocation r key = Git.repoLocation (repo r) </> objectDir </> keyPath key hashDirLower
+
+data AccessMethod = AccessDirect | AccessShell
+
+fromAccessMethod :: AccessMethod -> String
+fromAccessMethod AccessShell = "shell"
+fromAccessMethod AccessDirect = "true"
+
+toAccessMethod :: String -> AccessMethod
+toAccessMethod "shell" = AccessShell
+toAccessMethod _ = AccessDirect
+

Remote/Rsync.hs

@@ -236,7 +236,7 @@ sendParams = ifM crippledFileSystem
 
 {- Runs an action in an empty scratch directory that can be used to build
  - up trees for rsync. -}
-withRsyncScratchDir :: (FilePath -> Annex Bool) -> Annex Bool
+withRsyncScratchDir :: (FilePath -> Annex a) -> Annex a
 withRsyncScratchDir a = do
 #ifndef mingw32_HOST_OS
 	v <- liftIO getProcessID

Types/GitConfig.hs

@@ -42,6 +42,7 @@ data GitConfig = GitConfig
 	, annexCrippledFileSystem :: Bool
 	, annexLargeFiles :: Maybe String
 	, coreSymlinks :: Bool
+	, gcryptId :: Maybe String
 	}
 
 extractGitConfig :: Git.Repo -> GitConfig
@@ -68,6 +69,7 @@ extractGitConfig r = GitConfig
 	, annexCrippledFileSystem = getbool (annex "crippledfilesystem") False
 	, annexLargeFiles = getmaybe (annex "largefiles")
 	, coreSymlinks = getbool "core.symlinks" True
+	, gcryptId = getmaybe "core.gcrypt-id"
 	}
   where
 	get k def = fromMaybe def $ getmayberead k
@@ -104,6 +106,7 @@ data RemoteGitConfig = RemoteGitConfig
 	, remoteAnnexBupRepo :: Maybe String
 	, remoteAnnexBupSplitOptions :: [String]
 	, remoteAnnexDirectory :: Maybe FilePath
+	, remoteAnnexGCrypt :: Maybe String
 	, remoteAnnexHookType :: Maybe String
 	{- A regular git remote's git repository config. -}
 	, remoteGitConfig :: Maybe GitConfig
@@ -127,6 +130,7 @@ extractRemoteGitConfig r remotename = RemoteGitConfig
 	, remoteAnnexBupRepo = getmaybe "buprepo"
 	, remoteAnnexBupSplitOptions = getoptions "bup-split-options"
 	, remoteAnnexDirectory = notempty $ getmaybe "directory"
+	, remoteAnnexGCrypt = notempty $ getmaybe "gcrypt"
 	, remoteAnnexHookType = notempty $ getmaybe "hooktype"
 	, remoteGitConfig = Nothing
 	}

debian/NEWS

@@ -1,3 +1,11 @@
+git-annex (4.20130921) unstable; urgency=low
+
+   The layout of gcrypt repositories has changed, and
+   if you created one you must manually upgrade it.
+   See /usr/share/doc/git-annex/html/upgrades/gcrypt.html
+
+ -- Joey Hess <joeyh@debian.org>  Tue, 24 Sep 2013 13:55:23 -0400
+
 git-annex (3.20120123) unstable; urgency=low
 
   There was a bug in the handling of directory special remotes that

debian/changelog

@@ -1,5 +1,9 @@
 git-annex (4.20130921) UNRELEASED; urgency=low
 
+  * Note that the layout of gcrypt repositories has changed, and
+    if you created one you must manually upgrade it.
+    See http://git-annex.branchable.com/upgrades/gcrypt/
+  * git-annex-shell: Added support for operating inside gcrypt repositories.
   * Use cryptohash rather than SHA for hashing when no external hash program
     is available. This is a significant speedup for SHA256 on OSX, for
     example.

doc/git-annex.mdwn

@@ -1230,6 +1230,15 @@ Here are all the supported configuration settings.
   Used to identify the XMPP address of a Jabber buddy.
   Normally this is set up by the git-annex assistant when pairing over XMPP.
 
+* `remote.<name>.gcrypt`
+
+  Used to identify gcrypt special remotes.
+  Normally this is automatically set up by `git annex initremote`.
+
+  It is set to "true" if this is a gcrypt remote.
+  If the gcrypt remote is accessible over ssh and has git-annex-shell
+  available to manage it, it's set to "shell"
+
 # CONFIGURATION VIA .gitattributes
 
 The key-value backend used when adding a new file to the annex can be

doc/special_remotes/gcrypt.mdwn

@@ -29,7 +29,9 @@ gcrypt:
 ## notes
 
 For git-annex to store files in a repository on a remote server, you need
-shell access, and `rsync` must be installed. 
+shell access, and `rsync` must be installed. Those are the minimum
+requirements, but it's also recommended to install git-annex on the remote
+server, so that [[git-annex-shell]] can be used.
 
 While you can use git-remote-gcrypt with servers like github, git-annex
 can't store files on them. In such a case, you can just use

doc/tips/fully_encrypted_git_repositories_with_gcrypt.mdwn

@@ -50,14 +50,18 @@ the gpg key used to encrypt it, and then:
 
 ## encrypted git-annex repository on a ssh server
 
-If you have a ssh server that has git-annex and rsync installed, you can
-set up an encrypted repository there. Works just like the encrypted drive
-except without the cable.
+If you have a ssh server that has rsync installed, you can set up an
+encrypted repository there. Works just like the encrypted drive except
+without the cable.
 
 First, on the server, run:
 
 	git init --bare encryptedrepo
 
+(Also, install git-annex on the server if it's possible & easy to do so.
+While this will work without git-annex being installed on the server, it
+is recommended to have it installed.)
+
 Now, in your existing git-annex repository:
 
 	git annex initremote encryptedrepo type=gcrypt gitrepo=ssh://my.server/home/me/encryptedrepo keyid=$mykey

doc/upgrades/gcrypt.mdwn

@@ -0,0 +1,25 @@
+Unfortunately the initial gcrypt repository layout had to be changed
+after git-annex version 4.20130920. If you have an encrypted git repository
+created using version 4.20130920 or 4.20130909, you need to manually
+upgrade it.
+
+If you look at the contents of your gcrypt repository, you will
+see a bare git repository, with a few three-letter subdirectories,
+which are where git-annex stores its encrypted file contents:
+
+<pre>
+27f/  branches/  description  hooks/  objects/
+HEAD  config     f37/         info/   refs/
+</pre>
+
+In the example above, the subdirectories are `27f` and `f37`.
+
+All you need to do to transition is move those subdirectories
+into an `annex/objects` directory.
+
+	mkdir annex ; mkdir annex/objects ; mv 27f f37 annex/objects
+
+Probably those are the only 3 letter things inside your git repository,
+so this will probably work:
+
+	mkdir annex ; mkdir annex/objects ; mv ??? annex