From a41255723c55d0046e8a9953a7ebaef9d2196bb5 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Mon, 10 Sep 2012 18:18:55 -0400
Subject: [PATCH] check that ssh public key received over the wire is sane
---
Assistant/Ssh.hs | 13 +++++++++
Assistant/WebApp/Configurators/Pairing.hs | 32 ++++++++++++++++-------
2 files changed, 35 insertions(+), 10 deletions(-)
diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs
index 7e72dd99df..c158f7dd26 100644
--- a/Assistant/Ssh.hs
+++ b/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"
diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs
index 96c053b86d..2e90eec36e 100644
--- a/Assistant/WebApp/Configurators/Pairing.hs
+++ b/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