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.

4 files changed, 15 insertions, 7 deletions

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')