avoid the dashed ssh hostname class of security holes

Security fix: Disallow hostname starting with a dash, which would get
passed to ssh and be treated an option. This could be used by an attacker
who provides a crafted ssh url (for eg a git remote) to execute arbitrary
code via ssh -oProxyCommand.

No CVE has yet been assigned for this hole.
The same class of security hole recently affected git itself,
CVE-2017-1000117.

Method: Identified all places where ssh is run, by git grep '"ssh"'
Converted them all to use a SshHost, if they did not already, for
specifying the hostname.

SshHost was made a data type with a smart constructor, which rejects
hostnames starting with '-'.

Note that git-annex already contains extensive use of Utility.SafeCommand,
which fixes a similar class of problem where a filename starting with a
dash gets passed to a program which treats it as an option.

This commit was sponsored by Jochen Bartl on Patreon.

Annex/Ssh.hs

@@ -62,19 +62,18 @@ sshCommand cs (host, port) gc remotecmd = ifM (liftIO safe_GIT_SSH)
   where
 	go = do
 		ps <- sshOptions cs (host, port) gc []
-		return ("ssh", Param host:ps++[Param remotecmd])
+		return ("ssh", Param (fromSshHost host):ps++[Param remotecmd])
 
 {- Generates parameters to ssh to a given host (or user@host) on a given
  - port. This includes connection caching parameters, and any
  - ssh-options. Note that the host to ssh to and the command to run
  - are not included in the returned options. -}
-sshOptions :: ConsumeStdin -> (String, Maybe Integer) -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam]
+sshOptions :: ConsumeStdin -> (SshHost, Maybe Integer) -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam]
 sshOptions cs (host, port) gc opts = go =<< sshCachingInfo (host, port)
   where
 	go (Nothing, params) = return $ mkparams cs params
 	go (Just socketfile, params) = do
-		prepSocket socketfile gc
+		prepSocket socketfile gc host (mkparams NoConsumeStdin params)
-			(Param host : mkparams NoConsumeStdin params)
 			
 		return $ mkparams cs params
 	mkparams cs' ps = concat
@@ -98,7 +97,7 @@ consumeStdinParams NoConsumeStdin = [Param "-n"]
 
 {- Returns a filename to use for a ssh connection caching socket, and
  - parameters to enable ssh connection caching. -}
-sshCachingInfo :: (String, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam])
+sshCachingInfo :: (SshHost, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam])
 sshCachingInfo (host, port) = go =<< sshCacheDir
   where
 	go Nothing = return (Nothing, [])
@@ -169,8 +168,8 @@ portParams (Just port) = [Param "-p", Param $ show port]
  - Locks the socket lock file to prevent other git-annex processes from
  - stopping the ssh multiplexer on this socket.
  -}
-prepSocket :: FilePath -> RemoteGitConfig -> [CommandParam] -> Annex ()
+prepSocket :: FilePath -> RemoteGitConfig -> SshHost -> [CommandParam] -> Annex ()
-prepSocket socketfile gc sshparams = do
+prepSocket socketfile gc sshhost sshparams = do
 	-- There could be stale ssh connections hanging around
 	-- from a previous git-annex run that was interrupted.
 	-- This must run only once, before we have made any ssh connection,
@@ -205,7 +204,8 @@ prepSocket socketfile gc sshparams = do
 	-- get the connection started now.
 	makeconnection socketlock =
 		whenM (isNothing <$> fromLockCache socketlock) $ do
-			let startps = sshparams ++ startSshConnection gc
+			let startps = Param (fromSshHost sshhost) :
+				sshparams ++ startSshConnection gc
 			-- When we can start the connection in batch mode,
 			-- ssh won't prompt to the console.
 			(_, connected) <- liftIO $ processTranscript "ssh"
@@ -298,9 +298,10 @@ forceStopSsh socketfile = do
  - of the path to a socket file. At the same time, it needs to be unique
  - for each host.
  -}
-hostport2socket :: String -> Maybe Integer -> FilePath
+hostport2socket :: SshHost -> Maybe Integer -> FilePath
-hostport2socket host Nothing = hostport2socket' host
+hostport2socket host Nothing = hostport2socket' $ fromSshHost host
-hostport2socket host (Just port) = hostport2socket' $ host ++ "!" ++ show port
+hostport2socket host (Just port) = hostport2socket' $
+	fromSshHost host ++ "!" ++ show port
 hostport2socket' :: String -> FilePath
 hostport2socket' s
 	| length s > lengthofmd5s = show $ md5 $ encodeBS s
@@ -385,18 +386,18 @@ sshOptionsTo remote gc localr
 			( unchanged
 			, do
 				let port = Git.Url.port remote
-				(msockfile, cacheparams) <- sshCachingInfo (host, port)
+				let sshhost = either error id (mkSshHost host)
+				(msockfile, cacheparams) <- sshCachingInfo (sshhost, port)
 				case msockfile of
 					Nothing -> use []
 					Just sockfile -> do
-						prepSocket sockfile gc $
+						prepSocket sockfile gc sshhost $ concat
-							Param host : concat
+							[ cacheparams
-								[ cacheparams
+							, map Param (remoteAnnexSshOptions gc)
-								, map Param (remoteAnnexSshOptions gc)
+							, portParams port
-								, portParams port
+							, consumeStdinParams NoConsumeStdin
-								, consumeStdinParams NoConsumeStdin
+							, [Param "-T"]
-								, [Param "-T"]
+							]
-								]
 						use cacheparams
 			)
   where

Assistant/Pairing/MakeRemote.hs

@@ -42,9 +42,9 @@ finishedLocalPairing msg keypair = do
 			[ sshOpt "StrictHostKeyChecking" "no"
 			, sshOpt "NumberOfPasswordPrompts" "0"
 			, "-n"
-			, genSshHost (sshHostName sshdata) (sshUserName sshdata)
-			, "git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata)
 			]
+			(genSshHost (sshHostName sshdata) (sshUserName sshdata))
+			("git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata))
 			Nothing
 	r <- liftAnnex $ addRemote $ makeSshRemote sshdata
 	liftAnnex $ setRemoteCost (Remote.repo r) semiExpensiveRemoteCost

Assistant/Ssh.hs

@@ -14,6 +14,7 @@ import Utility.Rsync
 import Utility.FileMode
 import Utility.SshConfig
 import Git.Remote
+import Utility.SshHost
 
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -64,8 +65,9 @@ sshOpt :: String -> String -> String
 sshOpt k v = concat ["-o", k, "=", v]
 
 {- user@host or host -}
-genSshHost :: Text -> Maybe Text -> String
+genSshHost :: Text -> Maybe Text -> SshHost
-genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host
+genSshHost host user = either error id $ mkSshHost $
+	maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host
 
 {- Generates a ssh or rsync url from a SshData. -}
 genSshUrl :: SshData -> String
@@ -119,8 +121,9 @@ genSshRepoName host dir
 	| otherwise = makeLegalName $ host ++ "_" ++ dir
 
 {- The output of ssh, including both stdout and stderr. -}
-sshTranscript :: [String] -> (Maybe String) -> IO (String, Bool)
+sshTranscript :: [String] -> SshHost -> String -> (Maybe String) -> IO (String, Bool)
-sshTranscript opts input = processTranscript "ssh" opts input
+sshTranscript opts sshhost cmd input = processTranscript "ssh"
+	(opts ++ [fromSshHost sshhost, cmd]) input
 
 {- Ensure that the ssh public key doesn't include any ssh options, like
  - command=foo, or other weirdness.

Assistant/WebApp/Configurators/Ssh.hs

@@ -39,6 +39,7 @@ import Utility.Tmp
 import Utility.FileMode
 import Utility.ThreadScheduler
 import Utility.Env
+import Utility.SshHost
 
 import qualified Data.Text as T
 import qualified Data.Map as M
@@ -299,12 +300,11 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do
 				if knownhost then "yes" else "no"
 			, "-n" -- don't read from stdin
 			, "-p", show (inputPort sshinput)
-			, genSshHost
-				(fromJust $ inputHostname sshinput)
-				(inputUsername sshinput)
-			, remotecommand
 			]
-		parsetranscript . fst <$> sshAuthTranscript sshinput sshopts Nothing
+		let sshhost = genSshHost
+			(fromJust $ inputHostname sshinput)
+			(inputUsername sshinput)
+		parsetranscript . fst <$> sshAuthTranscript sshinput sshopts sshhost remotecommand Nothing
 	parsetranscript s =
 		let cs = map snd $ filter (reported . fst)
 			[ ("git-annex-shell", GitAnnexShellCapable)
@@ -339,9 +339,9 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do
 
 {- Runs a ssh command to set up the repository; if it fails shows
  - the user the transcript, and if it succeeds, runs an action. -}
-sshSetup :: SshInput -> [String] -> Maybe String -> Handler Html -> Handler Html
+sshSetup :: SshInput -> [String] -> SshHost -> String -> Maybe String -> Handler Html -> Handler Html
-sshSetup sshinput opts input a = do
+sshSetup sshinput opts sshhost cmd input a = do
-	(transcript, ok) <- liftAssistant $ sshAuthTranscript sshinput opts input
+	(transcript, ok) <- liftAssistant $ sshAuthTranscript sshinput opts sshhost cmd input
 	if ok
 		then do
 			liftAssistant $ expireCachedCred $ getLogin sshinput
@@ -367,8 +367,8 @@ sshErr sshinput msg
  - cached password. ssh is coaxed to use git-annex as SSH_ASKPASS
  - to get the password.
  -}
-sshAuthTranscript :: SshInput -> [String] -> (Maybe String) -> Assistant (String, Bool)
+sshAuthTranscript :: SshInput -> [String] -> SshHost -> String -> (Maybe String) -> Assistant (String, Bool)
-sshAuthTranscript sshinput opts input = case inputAuthMethod sshinput of
+sshAuthTranscript sshinput opts sshhost cmd input = case inputAuthMethod sshinput of
 	ExistingSshKey -> liftIO $ go [passwordprompts 0] Nothing
 	CachedPassword -> setupAskPass
 	Password -> do
@@ -379,7 +379,7 @@ sshAuthTranscript sshinput opts input = case inputAuthMethod sshinput of
 	geti f = maybe "" T.unpack (f sshinput)
 
 	go extraopts environ = processTranscript' 
-		(askPass environ (proc "ssh" (extraopts ++ opts)))
+		(askPass environ (proc "ssh" (extraopts ++ opts ++ [fromSshHost sshhost, cmd])))
 		-- Always provide stdin, even when empty.
 		(Just (fromMaybe "" input))
 
@@ -521,10 +521,11 @@ prepSsh' needsinit origsshdata sshdata keypair a
 				]
 		a sshdata
 	| otherwise = sshSetup (mkSshInput origsshdata)
-		 [ "-p", show (sshPort origsshdata)
+		[ "-p", show (sshPort origsshdata)
-		 , genSshHost (sshHostName origsshdata) (sshUserName origsshdata)
+		]
-		 , remoteCommand
+		(genSshHost (sshHostName origsshdata) (sshUserName origsshdata))
-		 ] Nothing (a sshdata)
+		remoteCommand
+		Nothing (a sshdata)
   where
 	remotedir = T.unpack $ sshDirectory sshdata
 	remoteCommand = shellWrap $ intercalate "&&" $ catMaybes
@@ -625,7 +626,7 @@ getMakeRsyncNetGCryptR :: SshData -> RepoKey -> Handler Html
 getMakeRsyncNetGCryptR sshdata NoRepoKey = whenGcryptInstalled $
 	withNewSecretKey $ getMakeRsyncNetGCryptR sshdata . RepoKey
 getMakeRsyncNetGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $
-	sshSetup (mkSshInput sshdata) [sshhost, gitinit] Nothing $
+	sshSetup (mkSshInput sshdata) [] sshhost gitinit Nothing $
 		makeGCryptRepo NewRepo keyid sshdata
   where
 	sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
@@ -661,11 +662,9 @@ prepRsyncNet sshinput reponame a = do
 			, sshCapabilities = [RsyncCapable]
 			}
 	let sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
-	let torsyncnet cmd = filter (not . null)
+	let torsyncnet
-		[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
+		| knownhost = []
-		, sshhost
+		| otherwise = [sshOpt "StrictHostKeyChecking" "no"]
-		, cmd
-		]
 	{- I'd prefer to separate commands with && , but
 	 - rsync.net's shell does not support that. -}
 	let remotecommand = intercalate ";"
@@ -674,7 +673,8 @@ prepRsyncNet sshinput reponame a = do
 		, "dd of=.ssh/authorized_keys oflag=append conv=notrunc"
 		, "mkdir -p " ++ T.unpack (sshDirectory sshdata)
 		]
-	sshSetup sshinput (torsyncnet remotecommand) (Just $ sshPubKey keypair) (a sshdata)
+	sshSetup sshinput torsyncnet sshhost remotecommand
+		(Just $ sshPubKey keypair) (a sshdata)
 
 isRsyncNet :: Maybe Text -> Bool
 isRsyncNet Nothing = False

CHANGELOG

@@ -1,5 +1,10 @@
 git-annex (6.20170521) UNRELEASED; urgency=medium
 
+  * Security fix: Disallow hostname starting with a dash, which
+    would get passed to ssh and be treated an option. This could
+    be used by an attacker who provides a crafted ssh url to execute
+    arbitrary code via -oProxyCommand.
+    (The same class of security hole recently affected git itself.)
   * Fix build with QuickCheck 2.10.
   * fsck: Support --json.
   * Added GIT_ANNEX_VECTOR_CLOCK environment variable, which can be used to

Git/Ssh.hs

@@ -5,10 +5,11 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module Git.Ssh where
+module Git.Ssh (module Git.Ssh, module Utility.SshHost) where
 
 import Common
 import Utility.Env
+import Utility.SshHost
 
 import Data.Char
 
@@ -21,9 +22,6 @@ 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
@@ -59,8 +57,8 @@ gitSsh' host mp cmd extrasshparams = do
 
 	-- Git passes exactly these parameters to the ssh command.
 	gitps = map Param $ case mp of
-		Nothing -> [host, cmd]
+		Nothing -> [fromSshHost host, cmd]
-		Just p -> [host, "-p", show p, cmd]
+		Just p -> [fromSshHost host, "-p", show p, cmd]
 
 	-- Passing any extra parameters to the ssh command may
 	-- break some commands.

Remote/Ddar.hs

@@ -21,6 +21,7 @@ import Config.Cost
 import Remote.Helper.Special
 import Annex.Ssh
 import Annex.UUID
+import Utility.SshHost
 
 data DdarRepo = DdarRepo
 	{ ddarRepoConfig :: RemoteGitConfig
@@ -109,9 +110,8 @@ store ddarrepo = fileStorer $ \k src _p -> do
 	liftIO $ boolSystem "ddar" params
 
 {- Convert remote DdarRepo to host and path on remote end -}
-splitRemoteDdarRepo :: DdarRepo -> (String, String)
+splitRemoteDdarRepo :: DdarRepo -> (SshHost, String)
-splitRemoteDdarRepo ddarrepo =
+splitRemoteDdarRepo ddarrepo = (either error id $ mkSshHost host, ddarrepo')
-	(host, ddarrepo')
   where
 	(host, remainder) = span (/= ':') (ddarRepoLocation ddarrepo)
 	ddarrepo' = drop 1 remainder

Remote/GCrypt.hs

@@ -48,6 +48,7 @@ import Utility.Rsync
 import Utility.Tmp
 import Logs.Remote
 import Utility.Gpg
+import Utility.SshHost
 
 remote :: RemoteType
 remote = RemoteType {
@@ -158,8 +159,9 @@ rsyncTransport r gc
 		let rsyncpath = if "/~/" `isPrefixOf` path
 			then drop 3 path
 			else path
-		opts <- sshOptions ConsumeStdin (host, Nothing) gc []
+		let sshhost = either error id (mkSshHost host)
-		return (rsyncShell $ Param "ssh" : opts, host ++ ":" ++ rsyncpath, AccessShell)
+		opts <- sshOptions ConsumeStdin (sshhost, Nothing) gc []
+		return (rsyncShell $ Param "ssh" : opts, fromSshHost sshhost ++ ":" ++ rsyncpath, AccessShell)
 	othertransport = return ([], loc, AccessDirect)
 
 noCrypto :: Annex a

Remote/Helper/Ssh.hs

@@ -19,13 +19,17 @@ import Remote.Helper.Messages
 import Messages.Progress
 import Utility.Metered
 import Utility.Rsync
+import Utility.SshHost
 import Types.Remote
 import Types.Transfer
 import Config
 
 toRepo :: ConsumeStdin -> Git.Repo -> RemoteGitConfig -> SshCommand -> Annex (FilePath, [CommandParam])
 toRepo cs r gc remotecmd = do
-	let host = fromMaybe (giveup "bad ssh url") $ Git.Url.hostuser r
+	let host = maybe
+		(giveup "bad ssh url")
+		(either error id . mkSshHost)
+		(Git.Url.hostuser r)
 	sshCommand cs (host, Git.Url.port r) gc remotecmd
 
 {- Generates parameters to run a git-annex-shell command on a remote

Remote/Rsync.hs

@@ -38,6 +38,7 @@ import Types.Transfer
 import Types.Creds
 import Annex.DirHashes
 import Utility.Tmp
+import Utility.SshHost
 
 import qualified Data.Map as M
 
@@ -120,7 +121,8 @@ rsyncTransport gc url
 		case fromNull ["ssh"] (remoteAnnexRsyncTransport gc) of
 			"ssh":sshopts -> do
 				let (port, sshopts') = sshReadPort sshopts
-				    userhost = takeWhile (/=':') url
+				    userhost = either error id $ mkSshHost $ 
+				    	takeWhile (/= ':') url
 				(Param "ssh":) <$> sshOptions ConsumeStdin
 					(userhost, port) gc
 					(map Param $ loginopt ++ sshopts')

Utility/SshHost.hs

@@ -0,0 +1,29 @@
+{- ssh hostname sanitization
+ -
+ - When constructing a ssh command with a hostname that may be controlled
+ - by an attacker, prevent the hostname from starting with "-",
+ - to prevent tricking ssh into arbitrary command execution via
+ - eg "-oProxyCommand="
+ -
+ - Copyright 2017 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.SshHost (SshHost, mkSshHost, fromSshHost) where
+
+newtype SshHost = SshHost String
+
+-- | Smart constructor for a legal hostname or IP address.
+-- In some cases, it may be prefixed with "user@" to specify the remote
+-- user at the host.
+--
+-- For now, we only filter out the problem ones, because determining an
+-- actually legal hostnames is quite complicated.
+mkSshHost :: String -> Either String SshHost
+mkSshHost h@('-':_) = Left $
+	"rejecting ssh hostname that starts with '-' : " ++ h
+mkSshHost h = Right (SshHost h)
+
+fromSshHost :: SshHost -> String
+fromSshHost (SshHost h) = h

git-annex.cabal

@@ -1055,6 +1055,7 @@ Executable git-annex
     Utility.SimpleProtocol
     Utility.Split
     Utility.SshConfig
+    Utility.SshHost
     Utility.Su
     Utility.SystemDirectory
     Utility.TList