Support GIT_SSH and GIT_SSH_COMMAND

They are handled close the same as they are by git. However, unlike git,
git-annex sometimes needs to pass the -n parameter when using these.

So, this has the potential for breaking some setup, and perhaps there ought
to be a ANNEX_USE_GIT_SSH=1 needed to use these. But I'd rather avoid that
if possible, so let's see if anyone complains.

Almost all places where "ssh" was run have been changed to support the env
vars. Anything still calling sshOptions does not support them. In
particular, rsync special remotes don't. Seems that annex-rsync-transport
already gives sufficient control there.

(Fixed in passing: Remote.Helper.Ssh.toRepo used to extract
remoteAnnexSshOptions and pass them to sshOptions, which was redundant
since sshOptions also extracts those.)

This commit was sponsored by Jeff Goeke-Smith on Patreon.

1 files changed, 68 insertions, 0 deletions

diff --git a/Git/Ssh.hs b/Git/Ssh.hs
new file mode 100644
index 000000000..b5d90d7a2
--- /dev/null
+++ b/Git/Ssh.hs
@@ -0,0 +1,68 @@
+{- GIT_SSH and GIT_SSH_COMMAND support
+ -
+ - Copyright 2017 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Ssh where
+
+import Common
+import Utility.Env
+
+import Data.Char
+
+gitSshEnv :: String
+gitSshEnv = "GIT_SSH"
+
+gitSshCommandEnv :: String
+gitSshCommandEnv = "GIT_SSH_COMMAND"
+
+gitSshEnvSet :: IO Bool
+gitSshEnvSet = anyM (isJust <$$> getEnv) [gitSshEnv, gitSshCommandEnv]
+
+-- Either a hostname, or user@host
+type SshHost = String
+
+type SshPort = Integer
+
+-- Command to run on the remote host. It is run by the shell
+-- there, so any necessary shell escaping of parameters in it should
+-- already be done.
+type SshCommand = String
+
+-- | Checks for GIT_SSH and GIT_SSH_COMMAND and if set, returns
+-- a command and parameters to run to ssh.
+gitSsh :: SshHost -> Maybe SshPort -> SshCommand -> IO (Maybe (FilePath, [CommandParam]))
+gitSsh host mp cmd = do
+	gsc <- getEnv gitSshCommandEnv
+	case gsc of
+		Just c
+			-- git only runs the command with the shell
+			-- when it contains spaces; otherwise it's
+			-- treated the same as GIT_SSH
+			| any isSpace c -> ret "sh"
+				[ [ Param "-c"
+				  , Param (c ++ " \"$@\"")
+				  , Param c
+				  ]
+				, gitps
+				-- cmd is already shell escaped
+				-- for the remote side, but needs to be
+				-- shell-escaped once more since it's
+				-- passed through the local shell.
+				, [ Param $ shellEscape $ cmd ]
+				]
+			| otherwise -> ret c [ gitps, [Param cmd]]
+		Nothing -> do
+			gs <- getEnv gitSshEnv
+			case gs of
+				Just c -> ret c [ gitps, [Param cmd]]
+				Nothing -> return Nothing
+ where
+	-- git passes exactly these parameters, followed by another
+	-- parameter containing the remote command.
+	gitps = map Param $ case mp of
+		Nothing -> [host]
+		Just p -> [host, "-p", show p]
+	ret c ll = return $ Just (c, concat ll)