git-annex-shell gcryptsetup command

This was the least-bad alternative to get dedicated key gcrypt repos
working in the assistant.

4 files changed, 65 insertions, 23 deletions

diff --git a/Command/GCryptSetup.hs b/Command/GCryptSetup.hs
new file mode 100644
index 000000000..a27e470c1
--- /dev/null
+++ b/Command/GCryptSetup.hs
@@ -0,0 +1,35 @@
+{- git-annex command
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.GCryptSetup where
+
+import Common.Annex
+import Command
+import Annex.UUID
+import qualified Remote.GCrypt
+import qualified Git
+
+def :: [Command]
+def = [dontCheck repoExists $ noCommit $
+	command "gcryptsetup" paramValue seek
+		SectionPlumbing "sets up gcrypt repository"]
+
+seek :: [CommandSeek]
+seek = [withStrings start]
+
+start :: String -> CommandStart
+start gcryptid = next $ next $ do
+	g <- gitRepo
+	u <- getUUID
+	gu <- Remote.GCrypt.getGCryptUUID True g
+	if u == NoUUID && gu == Nothing
+		then if Git.repoIsLocalBare g
+			then do
+				void $ Remote.GCrypt.setupRepo gcryptid g
+				return True
+			else error "cannot use gcrypt in a non-bare repository"
+		else error "gcryptsetup permission denied"
diff --git a/GitAnnexShell.hs b/GitAnnexShell.hs
index c34b3b307..b5f6804e7 100644
--- a/GitAnnexShell.hs
+++ b/GitAnnexShell.hs
@@ -30,24 +30,26 @@ import qualified Command.RecvKey
 import qualified Command.SendKey
 import qualified Command.TransferInfo
 import qualified Command.Commit
+import qualified Command.GCryptSetup
 
 cmds_readonly :: [Command]
 cmds_readonly = concat
-	[ Command.ConfigList.def
-	, Command.InAnnex.def
-	, Command.SendKey.def
-	, Command.TransferInfo.def
+	[ gitAnnexShellCheck Command.ConfigList.def
+	, gitAnnexShellCheck Command.InAnnex.def
+	, gitAnnexShellCheck Command.SendKey.def
+	, gitAnnexShellCheck Command.TransferInfo.def
 	]
 
 cmds_notreadonly :: [Command]
 cmds_notreadonly = concat
-	[ Command.RecvKey.def
-	, Command.DropKey.def
-	, Command.Commit.def
+	[ gitAnnexShellCheck Command.RecvKey.def
+	, gitAnnexShellCheck Command.DropKey.def
+	, gitAnnexShellCheck Command.Commit.def
+	, Command.GCryptSetup.def
 	]
 
 cmds :: [Command]
-cmds = map gitAnnexShellCheck $ map adddirparam $ cmds_readonly ++ cmds_notreadonly
+cmds = map adddirparam $ cmds_readonly ++ cmds_notreadonly
   where
 	adddirparam c = c { cmdparamdesc = "DIRECTORY " ++ cmdparamdesc c }
 
@@ -191,8 +193,8 @@ checkEnv var = do
 
 {- 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
+gitAnnexShellCheck :: [Command] -> [Command]
+gitAnnexShellCheck = map $ addCheck okforshell . dontCheck repoExists
   where
 	okforshell = unlessM (isInitialized <||> isJust . gcryptId <$> Annex.getGitConfig) $
 		error "Not a git-annex or gcrypt repository."
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 3f2a80172..74facfdc7 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -9,7 +9,8 @@ module Remote.GCrypt (
 	remote,
 	gen,
 	getGCryptUUID,
-	coreGCryptId
+	coreGCryptId,
+	setupRepo
 ) where
 
 import qualified Data.Map as M
@@ -198,12 +199,12 @@ gCryptSetup mu c = go $ M.lookup "gitrepo" c
 setupRepo :: Git.GCrypt.GCryptId -> Git.Repo -> Annex AccessMethod
 setupRepo gcryptid r
 	| Git.repoIsUrl r = do
-		accessmethod <- rsyncsetup
+		(_, _, accessmethod) <- rsyncTransport r
 		case accessmethod of
-			AccessDirect -> return AccessDirect
-			AccessShell -> ifM usablegitannexshell
+			AccessDirect -> rsyncsetup
+			AccessShell -> ifM gitannexshellsetup
 				( return AccessShell
-				, return AccessDirect
+				, rsyncsetup
 				)
 	| Git.repoIsLocalUnknown r = localsetup =<< liftIO (Git.Config.read r)
 	| otherwise = localsetup r
@@ -220,15 +221,15 @@ setupRepo gcryptid r
 	 -}
   	rsyncsetup = Remote.Rsync.withRsyncScratchDir $ \tmp -> do
 		liftIO $ createDirectoryIfMissing True $ tmp </> objectDir
-		(rsynctransport, rsyncurl, accessmethod) <- rsyncTransport r
+		(rsynctransport, rsyncurl, _) <- rsyncTransport r
 		let tmpconfig = tmp </> "config"
 		void $ liftIO $ rsync $ rsynctransport ++
 			[ Param $ rsyncurl ++ "/config"
 			, Param tmpconfig
 			]
 		liftIO $ do
-			Git.Config.changeFile tmpconfig coreGCryptId gcryptid
-			Git.Config.changeFile tmpconfig denyNonFastForwards (Git.Config.boolConfig False)
+			void $ Git.Config.changeFile tmpconfig coreGCryptId gcryptid
+			void $ Git.Config.changeFile tmpconfig denyNonFastForwards (Git.Config.boolConfig False)
 		ok <- liftIO $ rsync $ rsynctransport ++
 			[ Params "--recursive"
 			, Param $ tmp ++ "/"
@@ -236,12 +237,12 @@ setupRepo gcryptid r
 			]
 		unless ok $
 			error "Failed to connect to remote to set it up."
-		return accessmethod
+		return AccessDirect
 
-	{-  Check if git-annex shell is installed, and is a new enough
-	 -  version to work in a gcrypt repo. -}
-	usablegitannexshell = either (const False) (const True)
-		<$> Ssh.onRemote r (Git.Config.fromPipe r, Left undefined) "configlist" [] []
+	{-  Ask git-annex-shell to configure the repository as a gcrypt
+	 -  repository. May fail if it is too old. -}
+	gitannexshellsetup = Ssh.onRemote r (boolSystem, False)
+		"gcryptsetup" [ Param gcryptid ] []
 
 	denyNonFastForwards = "receive.denyNonFastForwards"
 
diff --git a/doc/git-annex-shell.mdwn b/doc/git-annex-shell.mdwn
index 38659d0e2..c866154ac 100644
--- a/doc/git-annex-shell.mdwn
+++ b/doc/git-annex-shell.mdwn
@@ -60,6 +60,10 @@ first "/~/" or "/~user/" is expanded to the specified home directory.
   This commits any staged changes to the git-annex branch.
   It also runs the annex-content hook.
 
+* gcryptsetup gcryptid
+
+  Sets up a repository as a gcrypt repository.
+
 # OPTIONS
 
 Most options are the same as in git-annex. The ones specific