diff options
| -rw-r--r-- | Assistant/Ssh.hs | 13 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators/Pairing.hs | 32 |
2 files changed, 35 insertions, 10 deletions
diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs index 7e72dd99d..c158f7dd2 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 96c053b86..2e90eec36 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 |