summaryrefslogtreecommitdiff
path: root/Assistant/WebApp/Configurators
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-09-10 18:18:55 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-09-10 18:18:55 -0400
commita41255723c55d0046e8a9953a7ebaef9d2196bb5 (patch)
tree5a62b90130f0c8ecdac220392191fd3dbf04c93b /Assistant/WebApp/Configurators
parentc20d6f4189e1e0c3a1e8339f772df587fac38748 (diff)
check that ssh public key received over the wire is sane
Diffstat (limited to 'Assistant/WebApp/Configurators')
-rw-r--r--Assistant/WebApp/Configurators/Pairing.hs32
1 files changed, 22 insertions, 10 deletions
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