webapp can now set up gcrypt repos on ssh servers

3 files changed, 21 insertions, 20 deletions

diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs
index 1880d519e..d85bf0fd7 100644
--- a/Assistant/MakeRemote.hs
+++ b/Assistant/MakeRemote.hs
@@ -27,20 +27,18 @@ import Utility.Gpg (KeyId)
 import qualified Data.Text as T
 import qualified Data.Map as M
 
-{- Sets up a new ssh or rsync remote. -}
-makeSshRemote :: Bool -> SshData -> Annex RemoteName
-makeSshRemote forcersync sshdata = 
-	maker (sshRepoName sshdata) (sshUrl forcersync sshdata)
+{- Sets up a new git or rsync remote, accessed over ssh. -}
+makeSshRemote :: SshData -> Annex RemoteName
+makeSshRemote sshdata = maker (sshRepoName sshdata) (sshUrl sshdata)
   where
-	rsync = forcersync || sshCapabilities sshdata == [RsyncCapable]
 	maker
-		| rsync = makeRsyncRemote
+		| onlyCapability sshdata RsyncCapable = makeRsyncRemote
 		| otherwise = makeGitRemote
 
 {- Generates a ssh or rsync url from a SshData. -}
-sshUrl :: Bool -> SshData -> String
-sshUrl forcersync sshdata = addtrailingslash $ T.unpack $ T.concat $
-	if (forcersync || sshCapabilities sshdata == [RsyncCapable])
+sshUrl :: SshData -> String
+sshUrl sshdata = addtrailingslash $ T.unpack $ T.concat $
+	if (onlyCapability sshdata RsyncCapable)
 		then [u, h, T.pack ":", sshDirectory sshdata]
 		else [T.pack "ssh://", u, h, d]
   where
diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs
index 47811963b..144b236a4 100644
--- a/Assistant/Pairing/MakeRemote.hs
+++ b/Assistant/Pairing/MakeRemote.hs
@@ -24,7 +24,7 @@ import qualified Data.Text as T
 setupAuthorizedKeys :: PairMsg -> FilePath -> IO ()
 setupAuthorizedKeys msg repodir = do
 	validateSshPubKey pubkey
-	unlessM (liftIO $ addAuthorizedKeys False repodir pubkey) $
+	unlessM (liftIO $ addAuthorizedKeys True repodir pubkey) $
 		error "failed setting up ssh authorized keys"
   where
 	pubkey = remoteSshPubKey $ pairMsgData msg
@@ -45,7 +45,7 @@ finishedLocalPairing msg keypair = do
 			, "git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata)
 			]
 			Nothing
-	r <- liftAnnex $ addRemote $ makeSshRemote False sshdata
+	r <- liftAnnex $ addRemote $ makeSshRemote sshdata
 	liftAnnex $ setRemoteCost r semiExpensiveRemoteCost
 	syncRemote r
 
diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs
index 9df9b64b9..c6514e613 100644
--- a/Assistant/Ssh.hs
+++ b/Assistant/Ssh.hs
@@ -35,6 +35,9 @@ data SshServerCapability = GitAnnexShellCapable | GitCapable | RsyncCapable
 hasCapability :: SshData -> SshServerCapability -> Bool
 hasCapability d c = c `elem` sshCapabilities d
 
+onlyCapability :: SshData -> SshServerCapability -> Bool
+onlyCapability d c = all (== c) (sshCapabilities d)
+
 data SshKeyPair = SshKeyPair
 	{ sshPubKey :: String
 	, sshPrivKey :: String
@@ -98,12 +101,12 @@ validateSshPubKey pubkey
 	safeincomment c = isAlphaNum c || c == '@' || c == '-' || c == '_' || c == '.'
 
 addAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO Bool
-addAuthorizedKeys rsynconly dir pubkey = boolSystem "sh"
-	[ Param "-c" , Param $ addAuthorizedKeysCommand rsynconly dir pubkey ]
+addAuthorizedKeys gitannexshellonly dir pubkey = boolSystem "sh"
+	[ Param "-c" , Param $ addAuthorizedKeysCommand gitannexshellonly dir pubkey ]
 
 removeAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO ()
-removeAuthorizedKeys rsynconly dir pubkey = do
-	let keyline = authorizedKeysLine rsynconly dir pubkey
+removeAuthorizedKeys gitannexshellonly dir pubkey = do
+	let keyline = authorizedKeysLine gitannexshellonly dir pubkey
 	sshdir <- sshDir
 	let keyfile = sshdir </> "authorized_keys"
 	ls <- lines <$> readFileStrict keyfile
@@ -116,7 +119,7 @@ removeAuthorizedKeys rsynconly dir pubkey = do
  - present.
  -}
 addAuthorizedKeysCommand :: Bool -> FilePath -> SshPubKey -> String
-addAuthorizedKeysCommand rsynconly dir pubkey = intercalate "&&"
+addAuthorizedKeysCommand gitannexshellonly dir pubkey = intercalate "&&"
 	[ "mkdir -p ~/.ssh"
 	, intercalate "; "
 		[ "if [ ! -e " ++ wrapper ++ " ]"
@@ -128,7 +131,7 @@ addAuthorizedKeysCommand rsynconly dir pubkey = intercalate "&&"
 	, "chmod 600 ~/.ssh/authorized_keys"
 	, unwords
 		[ "echo"
-		, shellEscape $ authorizedKeysLine rsynconly dir pubkey
+		, shellEscape $ authorizedKeysLine gitannexshellonly dir pubkey
 		, ">>~/.ssh/authorized_keys"
 		]
 	]
@@ -147,11 +150,11 @@ addAuthorizedKeysCommand rsynconly dir pubkey = intercalate "&&"
 	runshell var = "exec git-annex-shell -c \"" ++ var ++ "\""
 
 authorizedKeysLine :: Bool -> FilePath -> SshPubKey -> String
-authorizedKeysLine rsynconly dir pubkey
+authorizedKeysLine gitannexshellonly dir pubkey
+	| gitannexshellonly = limitcommand ++ pubkey
 	{- TODO: Locking down rsync is difficult, requiring a rather
 	 - long perl script. -}
-	| rsynconly = pubkey
-	| otherwise = limitcommand ++ pubkey
+	| otherwise = pubkey
   where
 	limitcommand = "command=\"GIT_ANNEX_SHELL_DIRECTORY="++shellEscape dir++" ~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding "