check that ssh public key received over the wire is sane

Assistant/Ssh.hs

@@ -83,6 +83,19 @@ sshTranscript opts input = do
 	return ()
 	return (transcript, ok)
 
+{- Ensure that the ssh public key doesn't include any ssh options, like
+ - command=foo, or other weirdness -}
+validateSshPubKey :: SshPubKey -> IO ()
+validateSshPubKey pubkey = do
+	let ws = words pubkey
+	when (length ws > 3 || length ws < 2) $
+		error $ "wrong number of words in ssh public key " ++ pubkey
+	let (ssh, keytype) = separate (== '-') (ws !! 0)
+	unless (ssh == "ssh" && all isAlphaNum keytype) $
+		error $ "bad ssh public key prefix " ++ ws !! 0
+	when (length ws == 3) $
+		unless (all (\c -> isAlphaNum c || c == '@') (ws !! 2)) $
+			error $ "bad comment in ssh public key " ++ pubkey
 
 makeAuthorizedKeys :: Bool -> SshPubKey -> IO Bool
 makeAuthorizedKeys rsynconly pubkey = boolSystem "sh"

Assistant/WebApp/Configurators/Pairing.hs

@@ -75,19 +75,11 @@ getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do
 	where
 		pubkey = remoteSshPubKey $ pairMsgData msg
 		setup  = do
+			validateSshPubKey pubKey
 			unlessM (liftIO $ makeAuthorizedKeys False pubkey) $
 				error "failed setting up ssh authorized keys"
 			keypair <- liftIO genSshKeyPair
-			let d = pairMsgData msg
-			besthostname <- liftIO $ bestHostName d
-			let sshdata = SshData
-				{ sshHostName = T.pack besthostname
-				, sshUserName = Just (T.pack $ remoteUserName d)
-				, sshDirectory = T.pack (remoteDirectory d)
-				, sshRepoName = genSshRepoName besthostname (remoteDirectory d)
-				, needsPubKey = True
-				, rsyncOnly = False
-				}
+			sshdata <- liftIO $ pairMsgToSshData msg
 			sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
 			void $ lift $ Ssh.makeSshWithKeyPair False sshdata' (Just keypair)
 			return keypair
@@ -96,6 +88,26 @@ getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do
 getFinishPairR _ = noPairing
 #endif
 
+{- Mostly a straightforward conversion.  Except:
+ -  * Determine the best hostname to use to contact the host.
+ -  * Strip leading ~/ from the directory name.
+ -}
+pairMsgToSshData :: PairMsg -> IO SshData
+pairMsgToSshData msg = do
+	let d = pairMsgData msg
+	hostname <- liftIO $ bestHostName d
+	let dir = case remoteDirectory d of
+		('~':'/':v) -> v
+		v -> v
+	return $ SshData
+		{ sshHostName = T.pack hostname
+		, sshUserName = Just (T.pack $ remoteUserName d)
+		, sshDirectory = T.pack dir
+		, sshRepoName = genSshRepoName besthostname dir
+		, needsPubKey = True
+		, rsyncOnly = False
+		}
+
 getInprogressPairR :: Text -> Handler RepHtml
 #ifdef WITH_PAIRING
 getInprogressPairR secret = pairPage $ do