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/

2 files changed, 129 insertions, 34 deletions

diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 27d368690..e5e7e8d48 100644
--- a/Remote/GCrypt.hs
+++ b/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
+
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index f1e6fd85e..76b786ec7 100644
--- a/Remote/Rsync.hs
+++ b/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