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.

11 files changed, 84 insertions, 39 deletions

diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs
index 4e6cc6a59..c3f46b4c1 100644
--- a/Annex/Ssh.hs
+++ b/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
-			(Param host : mkparams NoConsumeStdin params)
+		prepSocket socketfile gc 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 socketfile gc sshparams = do
+prepSocket :: FilePath -> RemoteGitConfig -> SshHost -> [CommandParam] -> Annex ()
+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 host Nothing = hostport2socket' host
-hostport2socket host (Just port) = hostport2socket' $ host ++ "!" ++ show port
+hostport2socket :: SshHost -> Maybe Integer -> FilePath
+hostport2socket host Nothing = hostport2socket' $ fromSshHost host
+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 $
-							Param host : concat
-								[ cacheparams
-								, map Param (remoteAnnexSshOptions gc)
-								, portParams port
-								, consumeStdinParams NoConsumeStdin
-								, [Param "-T"]
-								]
+						prepSocket sockfile gc sshhost $ concat
+							[ cacheparams
+							, map Param (remoteAnnexSshOptions gc)
+							, portParams port
+							, consumeStdinParams NoConsumeStdin
+							, [Param "-T"]
+							]
 						use cacheparams
 			)
   where
diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs
index e847edd39..a97bb31f0 100644
--- a/Assistant/Pairing/MakeRemote.hs
+++ b/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
diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs
index e439ecd23..fb4a39a17 100644
--- a/Assistant/Ssh.hs
+++ b/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 host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host
+genSshHost :: Text -> Maybe Text -> SshHost
+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 opts input = processTranscript "ssh" opts input
+sshTranscript :: [String] -> SshHost -> String -> (Maybe String) -> IO (String, Bool)
+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.
diff --git a/CHANGELOG b/CHANGELOG
index 603b7dc65..f3b36bf00 100644
--- a/CHANGELOG
+++ b/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
diff --git a/Git/Ssh.hs b/Git/Ssh.hs
index 206e72113..3c9b23905 100644
--- a/Git/Ssh.hs
+++ b/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]
-		Just p -> [host, "-p", show p, cmd]
+		Nothing -> [fromSshHost host, cmd]
+		Just p -> [fromSshHost host, "-p", show p, cmd]
 
 	-- Passing any extra parameters to the ssh command may
 	-- break some commands.
diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs
index e1c2a21e4..2f8c3b345 100644
--- a/Remote/Ddar.hs
+++ b/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 =
-	(host, ddarrepo')
+splitRemoteDdarRepo :: DdarRepo -> (SshHost, String)
+splitRemoteDdarRepo ddarrepo = (either error id $ mkSshHost host, ddarrepo')
   where
 	(host, remainder) = span (/= ':') (ddarRepoLocation ddarrepo)
 	ddarrepo' = drop 1 remainder
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index ee949ea08..2ccc47ad8 100644
--- a/Remote/GCrypt.hs
+++ b/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 []
-		return (rsyncShell $ Param "ssh" : opts, host ++ ":" ++ rsyncpath, AccessShell)
+		let sshhost = either error id (mkSshHost host)
+		opts <- sshOptions ConsumeStdin (sshhost, Nothing) gc []
+		return (rsyncShell $ Param "ssh" : opts, fromSshHost sshhost ++ ":" ++ rsyncpath, AccessShell)
 	othertransport = return ([], loc, AccessDirect)
 
 noCrypto :: Annex a
diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs
index 6dfadd117..a4d91ab92 100644
--- a/Remote/Helper/Ssh.hs
+++ b/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
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 681052e68..4fc55d725 100644
--- a/Remote/Rsync.hs
+++ b/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')
diff --git a/Utility/SshHost.hs b/Utility/SshHost.hs
new file mode 100644
index 000000000..d8a8da11d
--- /dev/null
+++ b/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
diff --git a/git-annex.cabal b/git-annex.cabal
index a5a1294c1..4b7eadfb7 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -1055,6 +1055,7 @@ Executable git-annex
     Utility.SimpleProtocol
     Utility.Split
     Utility.SshConfig
+    Utility.SshHost
     Utility.Su
     Utility.SystemDirectory
     Utility.TList