blind enabling gcrypt repos on rsync.net

This pulls off quite a nice trick: When given a path on rsync.net, it
determines if it is an encrypted git repository that the user has
the key to decrypt, and merges with it. This is works even when
the local repository had no idea that the gcrypt remote exists!

(As previously done with local drives.)

This commit sponsored by Pedro Côrte-Real

Assistant/WebApp/Configurators/Local.hs

@@ -252,7 +252,7 @@ getConfirmAddDriveR drive = ifM (liftIO $ probeRepoExists dir)
 		mu <- liftIO $ probeUUID dir
 		case mu of
 			Nothing -> maybe askcombine isknownuuid
-				=<< liftIO (probeGCryptRemoteUUID dir)
+				=<< liftAnnex (probeGCryptRemoteUUID dir)
 			Just driveuuid -> isknownuuid driveuuid
 	, newrepo
 	)
@@ -295,19 +295,17 @@ getFinishAddDriveR drive = go
 			makeGCryptRemote remotename dir keyid
 		return (Types.Remote.uuid r, r)
 	go NoRepoKey = checkGCryptRepoEncryption dir makeunencrypted $ do
-			mu <- liftIO $ probeGCryptRemoteUUID dir
+			mu <- liftAnnex $ probeGCryptRemoteUUID dir
 			case mu of
-				Just u -> enablegcryptremote u
+				Just u -> enableexistinggcryptremote u
 				Nothing -> error "The drive contains a gcrypt repository that is not a git-annex special remote. This is not supported."
-	enablegcryptremote u = do
+	enableexistinggcryptremote u = do
-		mname <- liftAnnex $ getGCryptRemoteName u dir
+		remotename' <- liftAnnex $ getGCryptRemoteName u dir
-		case mname of
+		makewith $ const $ do
-			Nothing -> error $ "Cannot find configuration for the gcrypt remote at " ++ dir
+			r <- liftAnnex $ addRemote $
-			Just name -> makewith $ const $ do
+				enableSpecialRemote remotename' GCrypt.remote $ M.fromList
-				r <- liftAnnex $ addRemote $
+					[("gitrepo", dir)]
-					enableSpecialRemote name GCrypt.remote $ M.fromList
+			return (u, r)
-						[("gitrepo", dir)]
-				return (u, r)
 	{- Making a new unencrypted repo, or combining with an existing one. -}
 	makeunencrypted = makewith $ \isnew -> (,)
 		<$> liftIO (initRepo isnew False dir $ Just remotename)
@@ -471,9 +469,3 @@ probeUUID :: FilePath -> IO (Maybe UUID)
 probeUUID dir = catchDefaultIO Nothing $ inDir dir $ do
 	u <- getUUID
 	return $ if u == NoUUID then Nothing else Just u
-
-{- Gets the UUID of the gcrypt repo at a location, which may not exist.
- - Only works if the gcrypt repo was created as a git-annex remote. -}
-probeGCryptRemoteUUID :: FilePath -> IO (Maybe UUID)
-probeGCryptRemoteUUID dir = catchDefaultIO Nothing $ do
-	GCrypt.getGCryptUUID =<< Git.Construct.fromAbsPath dir

Assistant/WebApp/Configurators/Ssh.hs

@@ -24,6 +24,7 @@ import Utility.Gpg
 import Types.Remote (RemoteConfigKey)
 import Git.Remote
 import Assistant.WebApp.Utility
+import qualified Remote.GCrypt as GCrypt
 
 import qualified Data.Text as T
 import qualified Data.Map as M
@@ -344,7 +345,8 @@ postAddRsyncNetR = do
 		$(widgetFile "configurators/rsync.net/add")
 	case result of
 		FormSuccess sshinput
-			| isRsyncNet (inputHostname sshinput) -> prep sshinput
+			| isRsyncNet (inputHostname sshinput) ->
+				go sshinput
 			| otherwise ->
 				showform $ UnusableServer
 					"That is not a rsync.net host name."
@@ -360,13 +362,28 @@ postAddRsyncNetR = do
   The host name will be something like "usw-s001.rsync.net", and the #
   user name something like "7491"
 |]
-	prep sshinput = do
+	go sshinput = do
 		let reponame = genSshRepoName "rsync.net" 
 			(maybe "" T.unpack $ inputDirectory sshinput)
-		prepRsyncNet sshinput reponame $ \sshdata -> inpage $ do
+		prepRsyncNet sshinput reponame $ \sshdata -> inpage $ 
-			secretkeys <- sortBy (comparing snd) . M.toList
+			checkexistinggcrypt sshdata $ do
-				<$> liftIO secretKeys
+				secretkeys <- sortBy (comparing snd) . M.toList
-			$(widgetFile "configurators/rsync.net/encrypt")					
+					<$> liftIO secretKeys
+				$(widgetFile "configurators/rsync.net/encrypt")
+	{- Detect if the user entered an existing gcrypt repository,
+	 - and enable it. -}
+	checkexistinggcrypt sshdata a = ifM (liftIO isGcryptInstalled)
+		( checkGCryptRepoEncryption repourl a $ do
+			mu <- liftAnnex $ probeGCryptRemoteUUID repourl
+			case mu of
+				Just u -> do
+					reponame <- liftAnnex $ getGCryptRemoteName u repourl
+					void $ liftH $ enableRsyncNetGCrypt' sshdata reponame
+				Nothing -> error "The location contains a gcrypt repository that is not a git-annex special remote. This is not supported."
+		, a
+		)
+	  where
+	  	repourl = sshUrl True sshdata
 
 getMakeRsyncNetSharedR :: SshData -> Handler Html
 getMakeRsyncNetSharedR sshdata = makeSshRepo True sshdata
@@ -387,16 +404,18 @@ enableRsyncNet :: SshInput -> String -> Handler Html
 enableRsyncNet sshinput reponame = 
 	prepRsyncNet sshinput reponame $ makeSshRepo True
 
-enableRsyncNetGCrypt :: SshInput -> String -> Handler Html
+enableRsyncNetGCrypt :: SshInput -> RemoteName -> Handler Html
 enableRsyncNetGCrypt sshinput reponame = 
-	prepRsyncNet sshinput reponame $ \sshdata -> do
+	prepRsyncNet sshinput reponame $ \sshdata ->
-  		let repourl = sshUrl True sshdata
+		checkGCryptRepoEncryption (sshUrl True sshdata) notencrypted $
-		checkGCryptRepoEncryption repourl notencrypted $
+			enableRsyncNetGCrypt' sshdata reponame
-			setupCloudRemote TransferGroup $ 
-				enableSpecialRemote reponame GCrypt.remote $ M.fromList
-					[("gitrepo", repourl)]
   where
-  	notencrypted = error "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository."
+	notencrypted = error "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository."
+enableRsyncNetGCrypt' :: SshData -> RemoteName -> Handler Html
+enableRsyncNetGCrypt' sshdata reponame = 
+	setupCloudRemote TransferGroup $ 
+		enableSpecialRemote reponame GCrypt.remote $ M.fromList
+			[("gitrepo", sshUrl True sshdata)]
 
 {- Prepares rsync.net ssh key, and if successful, runs an action with
  - its SshData. -}

Assistant/WebApp/Gpg.hs

@@ -14,8 +14,10 @@ import Assistant.Gpg
 import Utility.Gpg
 import qualified Git.Command
 import qualified Git.Remote
+import qualified Git.Construct
 import qualified Annex.Branch
 import qualified Git.GCrypt
+import qualified Remote.GCrypt as GCrypt
 import Assistant.MakeRemote
 import Logs.Remote
 
@@ -34,8 +36,11 @@ gpgKeyDisplay keyid userid = [whamlet|
 genKeyModal :: Widget
 genKeyModal = $(widgetFile "configurators/genkeymodal")
 
+isGcryptInstalled :: IO Bool
+isGcryptInstalled = inPath "git-remote-gcrypt"
+
 whenGcryptInstalled :: Handler Html -> Handler Html
-whenGcryptInstalled a = ifM (liftIO $ inPath "git-remote-gcrypt")
+whenGcryptInstalled a = ifM (liftIO isGcryptInstalled)
 	( a
 	, page "Need git-remote-gcrypt" (Just Configuration) $
 		$(widgetFile "configurators/needgcrypt")
@@ -58,7 +63,7 @@ withNewSecretKey use = do
  - branch from the gcrypt remote and merges it in, and then looks up
  - the name.
  -}
-getGCryptRemoteName :: UUID -> String -> Annex (Maybe Git.Remote.RemoteName)
+getGCryptRemoteName :: UUID -> String -> Annex Git.Remote.RemoteName
 getGCryptRemoteName u repoloc = do
 	tmpremote <- uniqueRemoteName "tmpgcryptremote" 0 <$> gitRepo
 	void $ inRepo $ Git.Command.runBool
@@ -70,9 +75,11 @@ getGCryptRemoteName u repoloc = do
 		, return Nothing
 		)
 	void $ inRepo $ Git.Remote.remove tmpremote
-	return mname
+	maybe missing return mname
+  where
+	missing = error $ "Cannot find configuration for the gcrypt remote at " ++ repoloc
 
-checkGCryptRepoEncryption :: String -> Handler Html -> Handler Html -> Handler Html
+checkGCryptRepoEncryption :: (Monad m, LiftAnnex m) => String -> m a -> m a -> m a
 checkGCryptRepoEncryption location notencrypted encrypted = 
 	dispatch =<< liftAnnex (inRepo $ Git.GCrypt.probeRepo location)
   where
@@ -80,3 +87,10 @@ checkGCryptRepoEncryption location notencrypted encrypted =
 	dispatch Git.GCrypt.NotEncrypted = notencrypted
 	dispatch Git.GCrypt.NotDecryptable =
 		error "This git repository is encrypted with a GnuPG key that you do not have."
+
+{- Gets the UUID of the gcrypt repo at a location, which may not exist.
+ - Only works if the gcrypt repo was created as a git-annex remote. -}
+probeGCryptRemoteUUID :: String -> Annex (Maybe UUID)
+probeGCryptRemoteUUID repolocation = do
+	r <- inRepo $ Git.Construct.fromRemoteLocation repolocation
+	GCrypt.getGCryptUUID False r

Git/Config.hs

@@ -168,3 +168,12 @@ fromPipe r cmd params = try $
   where
 	p = proc cmd $ toCommand params
 
+{- Reads git config from a specified file and returns the repo populated
+ - with the configuration. -}
+fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, String))
+fromFile r f = fromPipe r "git"
+	[ Param "config"
+	, Param "--file"
+	, File f
+	, Param "--list"
+	]

GitAnnexShell.hs

@@ -61,7 +61,7 @@ options = Option.common ++
 		check u | u == toUUID expected = noop
 		check NoUUID = checkGCryptUUID expected
 		check u = unexpectedUUID expected u
-	checkGCryptUUID expected = inRepo getGCryptUUID >>= check
+	checkGCryptUUID expected = check =<< getGCryptUUID True =<< gitRepo
 	  where
 	  	check (Just u) | u == toUUID expected = noop
 		check Nothing = unexpected expected "uninitialized repository"

Remote/GCrypt.hs

@@ -40,6 +40,7 @@ import Annex.UUID
 import Annex.Ssh
 import qualified Remote.Rsync
 import Utility.Rsync
+import Utility.Tmp
 import Logs.Remote
 import Logs.Transfer
 import Utility.Gpg
@@ -61,9 +62,9 @@ gen gcryptr u c gc = do
 	-- get underlying git repo with real path, not gcrypt path
 	r <- liftIO $ Git.GCrypt.encryptedRemote g gcryptr
 	let r' = r { Git.remoteName = Git.remoteName gcryptr }
-	(mgcryptid, r'') <- liftIO $ getGCryptId r'
+	-- doublecheck that cache matches underlying repo's gcrypt-id
-	-- doublecheck that local cache matches underlying repo's gcrypt-id
+	-- (which might not be set), only for local repos
-	-- (which might not be set)
+	(mgcryptid, r'') <- getGCryptId True r'
 	case (mgcryptid, Git.GCrypt.remoteRepoId g (Git.remoteName gcryptr)) of
 		(Just gcryptid, Just cachedgcryptid)
 			| gcryptid /= cachedgcryptid -> resetup gcryptid r''
@@ -87,24 +88,6 @@ 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.repoIsLocal r = do
-		r' <- catchDefaultIO r $ Git.Config.read 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 $
@@ -374,3 +357,39 @@ toAccessMethod :: String -> AccessMethod
 toAccessMethod "shell" = AccessShell
 toAccessMethod _ = AccessDirect
 
+getGCryptUUID :: Bool -> Git.Repo -> Annex (Maybe UUID)
+getGCryptUUID fast r = (genUUIDInNameSpace gCryptNameSpace <$>) . fst
+	<$> getGCryptId fast 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.
+ -
+ - In fast mode, only checks local repos. To check a remote repo,
+ - tries git-annex-shell and direct rsync of the git config file.
+ -
+ - (Also returns a version of input repo with its config read.) -}
+getGCryptId :: Bool -> Git.Repo -> Annex (Maybe Git.GCrypt.GCryptId, Git.Repo)
+getGCryptId fast r
+	| Git.repoIsLocal r = extract
+		=<< liftIO (catchDefaultIO r $ Git.Config.read r)
+	| not fast = do
+		fromshell <- Ssh.onRemote r (Git.Config.fromPipe r, Left undefined) "configlist" [] []
+		case fromshell of
+			Right (r', _) -> extract r'
+			Left _ -> do
+				(rsynctransport, rsyncurl, _) <- rsyncTransport r
+				fromrsync <- liftIO $ do
+					withTmpFile "tmpconfig" $ \tmpconfig _ -> do
+						void $ rsync $ rsynctransport ++
+							[ Param $ rsyncurl ++ "/config"
+							, Param tmpconfig
+							]
+						Git.Config.fromFile r tmpconfig
+				extract $ either (const r) fst fromrsync
+	| otherwise = return (Nothing, r)
+  where
+	extract r' = return (Git.Config.getMaybe coreGCryptId r', r')